1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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 Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Fname
.UF
; use Fname
.UF
;
40 with Namet
; use Namet
;
41 with Nmake
; use Nmake
;
42 with Nlists
; use Nlists
;
43 with Output
; use Output
;
44 with Sem_Aux
; use Sem_Aux
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Ch10
; use Sem_Ch10
;
47 with Sem_Ch12
; use Sem_Ch12
;
48 with Sem_Prag
; use Sem_Prag
;
49 with Sem_Util
; use Sem_Util
;
50 with Sinfo
; use Sinfo
;
51 with Sinput
; use Sinput
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Uname
; use Uname
;
55 with Tbuild
; use Tbuild
;
57 package body Inline
is
59 Check_Inlining_Restrictions
: constant Boolean := True;
60 -- In the following cases the frontend rejects inlining because they
61 -- are not handled well by the backend. This variable facilitates
62 -- disabling these restrictions to evaluate future versions of the
63 -- GCC backend in which some of the restrictions may be supported.
65 -- - subprograms that have:
66 -- - nested subprograms
68 -- - package declarations
69 -- - task or protected object declarations
70 -- - some of the following statements:
72 -- - asynchronous-select
73 -- - conditional-entry-call
79 Inlined_Calls
: Elist_Id
;
80 -- List of frontend inlined calls
82 Backend_Calls
: Elist_Id
;
83 -- List of inline calls passed to the backend
85 Backend_Inlined_Subps
: Elist_Id
;
86 -- List of subprograms inlined by the backend
88 Backend_Not_Inlined_Subps
: Elist_Id
;
89 -- List of subprograms that cannot be inlined by the backend
95 -- Inlined functions are actually placed in line by the backend if the
96 -- corresponding bodies are available (i.e. compiled). Whenever we find
97 -- a call to an inlined subprogram, we add the name of the enclosing
98 -- compilation unit to a worklist. After all compilation, and after
99 -- expansion of generic bodies, we traverse the list of pending bodies
100 -- and compile them as well.
102 package Inlined_Bodies
is new Table
.Table
(
103 Table_Component_Type
=> Entity_Id
,
104 Table_Index_Type
=> Int
,
105 Table_Low_Bound
=> 0,
106 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
107 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
108 Table_Name
=> "Inlined_Bodies");
110 -----------------------
111 -- Inline Processing --
112 -----------------------
114 -- For each call to an inlined subprogram, we make entries in a table
115 -- that stores caller and callee, and indicates the call direction from
116 -- one to the other. We also record the compilation unit that contains
117 -- the callee. After analyzing the bodies of all such compilation units,
118 -- we compute the transitive closure of inlined subprograms called from
119 -- the main compilation unit and make it available to the code generator
120 -- in no particular order, thus allowing cycles in the call graph.
122 Last_Inlined
: Entity_Id
:= Empty
;
124 -- For each entry in the table we keep a list of successors in topological
125 -- order, i.e. callers of the current subprogram.
127 type Subp_Index
is new Nat
;
128 No_Subp
: constant Subp_Index
:= 0;
130 -- The subprogram entities are hashed into the Inlined table
132 Num_Hash_Headers
: constant := 512;
134 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
137 type Succ_Index
is new Nat
;
138 No_Succ
: constant Succ_Index
:= 0;
140 type Succ_Info
is record
145 -- The following table stores list elements for the successor lists. These
146 -- lists cannot be chained directly through entries in the Inlined table,
147 -- because a given subprogram can appear in several such lists.
149 package Successors
is new Table
.Table
(
150 Table_Component_Type
=> Succ_Info
,
151 Table_Index_Type
=> Succ_Index
,
152 Table_Low_Bound
=> 1,
153 Table_Initial
=> Alloc
.Successors_Initial
,
154 Table_Increment
=> Alloc
.Successors_Increment
,
155 Table_Name
=> "Successors");
157 type Subp_Info
is record
158 Name
: Entity_Id
:= Empty
;
159 Next
: Subp_Index
:= No_Subp
;
160 First_Succ
: Succ_Index
:= No_Succ
;
161 Main_Call
: Boolean := False;
162 Processed
: Boolean := False;
165 package Inlined
is new Table
.Table
(
166 Table_Component_Type
=> Subp_Info
,
167 Table_Index_Type
=> Subp_Index
,
168 Table_Low_Bound
=> 1,
169 Table_Initial
=> Alloc
.Inlined_Initial
,
170 Table_Increment
=> Alloc
.Inlined_Increment
,
171 Table_Name
=> "Inlined");
173 -----------------------
174 -- Local Subprograms --
175 -----------------------
177 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
178 -- Make two entries in Inlined table, for an inlined subprogram being
179 -- called, and for the inlined subprogram that contains the call. If
180 -- the call is in the main compilation unit, Caller is Empty.
182 procedure Add_Inlined_Subprogram
(E
: Entity_Id
);
183 -- Add subprogram E to the list of inlined subprogram for the unit
185 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
186 -- Make entry in Inlined table for subprogram E, or return table index
187 -- that already holds E.
189 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
;
190 pragma Inline
(Get_Code_Unit_Entity
);
191 -- Return the entity node for the unit containing E. Always return the spec
194 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
195 -- If a candidate for inlining contains type declarations for types with
196 -- nontrivial initialization procedures, they are not worth inlining.
198 function Has_Single_Return
(N
: Node_Id
) return Boolean;
199 -- In general we cannot inline functions that return unconstrained type.
200 -- However, we can handle such functions if all return statements return a
201 -- local variable that is the only declaration in the body of the function.
202 -- In that case the call can be replaced by that local variable as is done
203 -- for other inlined calls.
205 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean;
206 -- Return True if E is in the main unit or its spec or in a subunit
208 function Is_Nested
(E
: Entity_Id
) return Boolean;
209 -- If the function is nested inside some other function, it will always
210 -- be compiled if that function is, so don't add it to the inline list.
211 -- We cannot compile a nested function outside the scope of the containing
212 -- function anyway. This is also the case if the function is defined in a
213 -- task body or within an entry (for example, an initialization procedure).
215 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
);
216 -- Remove all aspects and/or pragmas that have no meaning in inlined body
217 -- Body_Decl. The analysis of these items is performed on the non-inlined
218 -- body. The items currently removed are:
231 ------------------------------
232 -- Deferred Cleanup Actions --
233 ------------------------------
235 -- The cleanup actions for scopes that contain instantiations is delayed
236 -- until after expansion of those instantiations, because they may contain
237 -- finalizable objects or tasks that affect the cleanup code. A scope
238 -- that contains instantiations only needs to be finalized once, even
239 -- if it contains more than one instance. We keep a list of scopes
240 -- that must still be finalized, and call cleanup_actions after all
241 -- the instantiations have been completed.
245 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
246 -- Build set of scopes on which cleanup actions must be performed
248 procedure Cleanup_Scopes
;
249 -- Complete cleanup actions on scopes that need it
255 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
256 P1
: constant Subp_Index
:= Add_Subp
(Called
);
261 if Present
(Caller
) then
262 P2
:= Add_Subp
(Caller
);
264 -- Add P1 to the list of successors of P2, if not already there.
265 -- Note that P2 may contain more than one call to P1, and only
266 -- one needs to be recorded.
268 J
:= Inlined
.Table
(P2
).First_Succ
;
269 while J
/= No_Succ
loop
270 if Successors
.Table
(J
).Subp
= P1
then
274 J
:= Successors
.Table
(J
).Next
;
277 -- On exit, make a successor entry for P1
279 Successors
.Increment_Last
;
280 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
281 Successors
.Table
(Successors
.Last
).Next
:=
282 Inlined
.Table
(P2
).First_Succ
;
283 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
285 Inlined
.Table
(P1
).Main_Call
:= True;
289 ----------------------
290 -- Add_Inlined_Body --
291 ----------------------
293 procedure Add_Inlined_Body
(E
: Entity_Id
; N
: Node_Id
) is
295 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
296 -- Level of inlining for the call: Dont_Inline means no inlining,
297 -- Inline_Call means that only the call is considered for inlining,
298 -- Inline_Package means that the call is considered for inlining and
299 -- its package compiled and scanned for more inlining opportunities.
301 function Must_Inline
return Inline_Level_Type
;
302 -- Inlining is only done if the call statement N is in the main unit,
303 -- or within the body of another inlined subprogram.
309 function Must_Inline
return Inline_Level_Type
is
314 -- Check if call is in main unit
316 Scop
:= Current_Scope
;
318 -- Do not try to inline if scope is standard. This could happen, for
319 -- example, for a call to Add_Global_Declaration, and it causes
320 -- trouble to try to inline at this level.
322 if Scop
= Standard_Standard
then
326 -- Otherwise lookup scope stack to outer scope
328 while Scope
(Scop
) /= Standard_Standard
329 and then not Is_Child_Unit
(Scop
)
331 Scop
:= Scope
(Scop
);
334 Comp
:= Parent
(Scop
);
335 while Nkind
(Comp
) /= N_Compilation_Unit
loop
336 Comp
:= Parent
(Comp
);
339 -- If the call is in the main unit, inline the call and compile the
340 -- package of the subprogram to find more calls to be inlined.
342 if Comp
= Cunit
(Main_Unit
)
343 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
346 return Inline_Package
;
349 -- The call is not in the main unit. See if it is in some subprogram
350 -- that can be inlined outside its unit. If so, inline the call and,
351 -- if the inlining level is set to 1, stop there; otherwise also
352 -- compile the package as above.
354 Scop
:= Current_Scope
;
355 while Scope
(Scop
) /= Standard_Standard
356 and then not Is_Child_Unit
(Scop
)
358 if Is_Overloadable
(Scop
)
359 and then Is_Inlined
(Scop
)
360 and then not Is_Nested
(Scop
)
364 if Inline_Level
= 1 then
367 return Inline_Package
;
371 Scop
:= Scope
(Scop
);
377 Level
: Inline_Level_Type
;
379 -- Start of processing for Add_Inlined_Body
382 Append_New_Elmt
(N
, To
=> Backend_Calls
);
384 -- Skip subprograms that cannot be inlined outside their unit
386 if Is_Abstract_Subprogram
(E
)
387 or else Convention
(E
) = Convention_Protected
388 or else Is_Nested
(E
)
393 -- Find out whether the call must be inlined. Unless the result is
394 -- Dont_Inline, Must_Inline also creates an edge for the call in the
395 -- callgraph; however, it will not be activated until after Is_Called
396 -- is set on the subprogram.
398 Level
:= Must_Inline
;
400 if Level
= Dont_Inline
then
404 -- If the call was generated by the compiler and is to a subprogram in
405 -- a run-time unit, we need to suppress debugging information for it,
406 -- so that the code that is eventually inlined will not affect the
407 -- debugging of the program. We do not do it if the call comes from
408 -- source because, even if the call is inlined, the user may expect it
409 -- to be present in the debugging information.
411 if not Comes_From_Source
(N
)
412 and then In_Extended_Main_Source_Unit
(N
)
414 Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(E
)))
416 Set_Needs_Debug_Info
(E
, False);
419 -- If the subprogram is an expression function, then there is no need to
420 -- load any package body since the body of the function is in the spec.
422 if Is_Expression_Function
(E
) then
427 -- Find unit containing E, and add to list of inlined bodies if needed.
428 -- If the body is already present, no need to load any other unit. This
429 -- is the case for an initialization procedure, which appears in the
430 -- package declaration that contains the type. It is also the case if
431 -- the body has already been analyzed. Finally, if the unit enclosing
432 -- E is an instance, the instance body will be analyzed in any case,
433 -- and there is no need to add the enclosing unit (whose body might not
436 -- Library-level functions must be handled specially, because there is
437 -- no enclosing package to retrieve. In this case, it is the body of
438 -- the function that will have to be loaded.
441 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
446 Inlined_Bodies
.Increment_Last
;
447 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
449 elsif Ekind
(Pack
) = E_Package
then
452 if Is_Generic_Instance
(Pack
) then
455 -- Do not inline the package if the subprogram is an init proc
456 -- or other internally generated subprogram, because in that
457 -- case the subprogram body appears in the same unit that
458 -- declares the type, and that body is visible to the back end.
459 -- Do not inline it either if it is in the main unit.
460 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
461 -- calls if the back-end takes care of inlining the call.
463 elsif (Level
= Inline_Package
464 or else (Level
= Inline_Call
465 and then Has_Pragma_Inline_Always
(E
)
466 and then Back_End_Inlining
))
467 and then not Is_Inlined
(Pack
)
468 and then not Is_Internal
(E
)
469 and then not In_Main_Unit_Or_Subunit
(Pack
)
471 Set_Is_Inlined
(Pack
);
472 Inlined_Bodies
.Increment_Last
;
473 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
477 -- Ensure that Analyze_Inlined_Bodies will be invoked after
478 -- completing the analysis of the current unit.
480 Inline_Processing_Required
:= True;
482 end Add_Inlined_Body
;
484 ----------------------------
485 -- Add_Inlined_Subprogram --
486 ----------------------------
488 procedure Add_Inlined_Subprogram
(E
: Entity_Id
) is
489 Decl
: constant Node_Id
:= Parent
(Declaration_Node
(E
));
490 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
492 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
493 -- Append Subp to the list of subprograms inlined by the backend
495 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
496 -- Append Subp to the list of subprograms that cannot be inlined by
499 -----------------------------------------
500 -- Register_Backend_Inlined_Subprogram --
501 -----------------------------------------
503 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
505 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
506 end Register_Backend_Inlined_Subprogram
;
508 ---------------------------------------------
509 -- Register_Backend_Not_Inlined_Subprogram --
510 ---------------------------------------------
512 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
514 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
515 end Register_Backend_Not_Inlined_Subprogram
;
517 -- Start of processing for Add_Inlined_Subprogram
520 -- If the subprogram is to be inlined, and if its unit is known to be
521 -- inlined or is an instance whose body will be analyzed anyway or the
522 -- subprogram was generated as a body by the compiler (for example an
523 -- initialization procedure) or its declaration was provided along with
524 -- the body (for example an expression function), and if it is declared
525 -- at the library level not in the main unit, and if it can be inlined
526 -- by the back-end, then insert it in the list of inlined subprograms.
529 and then (Is_Inlined
(Pack
)
530 or else Is_Generic_Instance
(Pack
)
531 or else Nkind
(Decl
) = N_Subprogram_Body
532 or else Present
(Corresponding_Body
(Decl
)))
533 and then not In_Main_Unit_Or_Subunit
(E
)
534 and then not Is_Nested
(E
)
535 and then not Has_Initialized_Type
(E
)
537 Register_Backend_Inlined_Subprogram
(E
);
539 if No
(Last_Inlined
) then
540 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
542 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
548 Register_Backend_Not_Inlined_Subprogram
(E
);
550 end Add_Inlined_Subprogram
;
552 ------------------------
553 -- Add_Scope_To_Clean --
554 ------------------------
556 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
557 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
561 -- If the instance appears in a library-level package declaration,
562 -- all finalization is global, and nothing needs doing here.
564 if Scop
= Standard_Standard
then
568 -- If the instance is within a generic unit, no finalization code
569 -- can be generated. Note that at this point all bodies have been
570 -- analyzed, and the scope stack itself is not present, and the flag
571 -- Inside_A_Generic is not set.
578 while Present
(S
) and then S
/= Standard_Standard
loop
579 if Is_Generic_Unit
(S
) then
587 Elmt
:= First_Elmt
(To_Clean
);
588 while Present
(Elmt
) loop
589 if Node
(Elmt
) = Scop
then
593 Elmt
:= Next_Elmt
(Elmt
);
596 Append_Elmt
(Scop
, To_Clean
);
597 end Add_Scope_To_Clean
;
603 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
604 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
608 -- Initialize entry in Inlined table
610 procedure New_Entry
is
612 Inlined
.Increment_Last
;
613 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
614 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
615 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
616 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
617 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
620 -- Start of processing for Add_Subp
623 if Hash_Headers
(Index
) = No_Subp
then
625 Hash_Headers
(Index
) := Inlined
.Last
;
629 J
:= Hash_Headers
(Index
);
630 while J
/= No_Subp
loop
631 if Inlined
.Table
(J
).Name
= E
then
635 J
:= Inlined
.Table
(J
).Next
;
639 -- On exit, subprogram was not found. Enter in table. Index is
640 -- the current last entry on the hash chain.
643 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
648 ----------------------------
649 -- Analyze_Inlined_Bodies --
650 ----------------------------
652 procedure Analyze_Inlined_Bodies
is
659 type Pending_Index
is new Nat
;
661 package Pending_Inlined
is new Table
.Table
(
662 Table_Component_Type
=> Subp_Index
,
663 Table_Index_Type
=> Pending_Index
,
664 Table_Low_Bound
=> 1,
665 Table_Initial
=> Alloc
.Inlined_Initial
,
666 Table_Increment
=> Alloc
.Inlined_Increment
,
667 Table_Name
=> "Pending_Inlined");
668 -- The workpile used to compute the transitive closure
670 function Is_Ancestor_Of_Main
672 Nam
: Node_Id
) return Boolean;
673 -- Determine whether the unit whose body is loaded is an ancestor of
674 -- the main unit, and has a with_clause on it. The body is not
675 -- analyzed yet, so the check is purely lexical: the name of the with
676 -- clause is a selected component, and names of ancestors must match.
678 -------------------------
679 -- Is_Ancestor_Of_Main --
680 -------------------------
682 function Is_Ancestor_Of_Main
684 Nam
: Node_Id
) return Boolean
689 if Nkind
(Nam
) /= N_Selected_Component
then
693 if Chars
(Selector_Name
(Nam
)) /=
694 Chars
(Cunit_Entity
(Main_Unit
))
699 Pref
:= Prefix
(Nam
);
700 if Nkind
(Pref
) = N_Identifier
then
702 -- Par is an ancestor of Par.Child.
704 return Chars
(Pref
) = Chars
(U_Name
);
706 elsif Nkind
(Pref
) = N_Selected_Component
707 and then Chars
(Selector_Name
(Pref
)) = Chars
(U_Name
)
709 -- Par.Child is an ancestor of Par.Child.Grand.
711 return True; -- should check that ancestor match
714 -- A is an ancestor of A.B.C if it is an ancestor of A.B
716 return Is_Ancestor_Of_Main
(U_Name
, Pref
);
719 end Is_Ancestor_Of_Main
;
721 -- Start of processing for Analyze_Inlined_Bodies
724 if Serious_Errors_Detected
= 0 then
725 Push_Scope
(Standard_Standard
);
728 while J
<= Inlined_Bodies
.Last
729 and then Serious_Errors_Detected
= 0
731 Pack
:= Inlined_Bodies
.Table
(J
);
733 and then Scope
(Pack
) /= Standard_Standard
734 and then not Is_Child_Unit
(Pack
)
736 Pack
:= Scope
(Pack
);
739 Comp_Unit
:= Parent
(Pack
);
740 while Present
(Comp_Unit
)
741 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
743 Comp_Unit
:= Parent
(Comp_Unit
);
746 -- Load the body, unless it is the main unit, or is an instance
747 -- whose body has already been analyzed.
749 if Present
(Comp_Unit
)
750 and then Comp_Unit
/= Cunit
(Main_Unit
)
751 and then Body_Required
(Comp_Unit
)
752 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
753 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
756 Bname
: constant Unit_Name_Type
:=
757 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
762 if not Is_Loaded
(Bname
) then
763 Style_Check
:= False;
764 Load_Needed_Body
(Comp_Unit
, OK
, Do_Analyze
=> False);
768 -- Warn that a body was not available for inlining
771 Error_Msg_Unit_1
:= Bname
;
773 ("one or more inlined subprograms accessed in $!??",
776 Get_File_Name
(Bname
, Subunit
=> False);
777 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
780 -- If the package to be inlined is an ancestor unit of
781 -- the main unit, and it has a semantic dependence on
782 -- it, the inlining cannot take place to prevent an
783 -- elaboration circularity. The desired body is not
784 -- analyzed yet, to prevent the completion of Taft
785 -- amendment types that would lead to elaboration
786 -- circularities in gigi.
789 U_Id
: constant Entity_Id
:=
790 Defining_Entity
(Unit
(Comp_Unit
));
791 Body_Unit
: constant Node_Id
:=
792 Library_Unit
(Comp_Unit
);
796 Item
:= First
(Context_Items
(Body_Unit
));
797 while Present
(Item
) loop
798 if Nkind
(Item
) = N_With_Clause
800 Is_Ancestor_Of_Main
(U_Id
, Name
(Item
))
802 Set_Is_Inlined
(U_Id
, False);
809 -- If no suspicious with_clauses, analyze the body.
811 if Is_Inlined
(U_Id
) then
812 Semantics
(Body_Unit
);
822 if J
> Inlined_Bodies
.Last
then
824 -- The analysis of required bodies may have produced additional
825 -- generic instantiations. To obtain further inlining, we need
826 -- to perform another round of generic body instantiations.
830 -- Symmetrically, the instantiation of required generic bodies
831 -- may have caused additional bodies to be inlined. To obtain
832 -- further inlining, we keep looping over the inlined bodies.
836 -- The list of inlined subprograms is an overestimate, because it
837 -- includes inlined functions called from functions that are compiled
838 -- as part of an inlined package, but are not themselves called. An
839 -- accurate computation of just those subprograms that are needed
840 -- requires that we perform a transitive closure over the call graph,
841 -- starting from calls in the main compilation unit.
843 for Index
in Inlined
.First
.. Inlined
.Last
loop
844 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
846 -- This means that Add_Inlined_Body added the subprogram to the
847 -- table but wasn't able to handle its code unit. Do nothing.
849 Inlined
.Table
(Index
).Processed
:= True;
851 elsif Inlined
.Table
(Index
).Main_Call
then
852 Pending_Inlined
.Increment_Last
;
853 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
854 Inlined
.Table
(Index
).Processed
:= True;
857 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
861 -- Iterate over the workpile until it is emptied, propagating the
862 -- Is_Called flag to the successors of the processed subprogram.
864 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
865 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
866 Pending_Inlined
.Decrement_Last
;
868 S
:= Inlined
.Table
(Subp
).First_Succ
;
870 while S
/= No_Succ
loop
871 Subp
:= Successors
.Table
(S
).Subp
;
873 if not Inlined
.Table
(Subp
).Processed
then
874 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
875 Pending_Inlined
.Increment_Last
;
876 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
877 Inlined
.Table
(Subp
).Processed
:= True;
880 S
:= Successors
.Table
(S
).Next
;
884 -- Finally add the called subprograms to the list of inlined
885 -- subprograms for the unit.
887 for Index
in Inlined
.First
.. Inlined
.Last
loop
888 if Is_Called
(Inlined
.Table
(Index
).Name
) then
889 Add_Inlined_Subprogram
(Inlined
.Table
(Index
).Name
);
895 end Analyze_Inlined_Bodies
;
897 --------------------------
898 -- Build_Body_To_Inline --
899 --------------------------
901 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
902 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
903 Analysis_Status
: constant Boolean := Full_Analysis
;
904 Original_Body
: Node_Id
;
905 Body_To_Analyze
: Node_Id
;
906 Max_Size
: constant := 10;
908 function Has_Pending_Instantiation
return Boolean;
909 -- If some enclosing body contains instantiations that appear before
910 -- the corresponding generic body, the enclosing body has a freeze node
911 -- so that it can be elaborated after the generic itself. This might
912 -- conflict with subsequent inlinings, so that it is unsafe to try to
913 -- inline in such a case.
915 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
916 -- This function is called only in GNATprove mode, and it returns
917 -- True if the subprogram has no return statement or a single return
918 -- statement as last statement. It returns False for subprogram with
919 -- a single return as last statement inside one or more blocks, as
920 -- inlining would generate gotos in that case as well (although the
921 -- goto is useless in that case).
923 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
924 -- If the body of the subprogram includes a call that returns an
925 -- unconstrained type, the secondary stack is involved, and it
926 -- is not worth inlining.
928 -------------------------------
929 -- Has_Pending_Instantiation --
930 -------------------------------
932 function Has_Pending_Instantiation
return Boolean is
937 while Present
(S
) loop
938 if Is_Compilation_Unit
(S
)
939 or else Is_Child_Unit
(S
)
943 elsif Ekind
(S
) = E_Package
944 and then Has_Forward_Instantiation
(S
)
953 end Has_Pending_Instantiation
;
955 -----------------------------------------
956 -- Has_Single_Return_In_GNATprove_Mode --
957 -----------------------------------------
959 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
960 Last_Statement
: Node_Id
:= Empty
;
962 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
963 -- Returns OK on node N if this is not a return statement different
964 -- from the last statement in the subprogram.
970 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
972 if Nkind_In
(N
, N_Simple_Return_Statement
,
973 N_Extended_Return_Statement
)
975 if N
= Last_Statement
then
986 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
988 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
991 -- Retrieve the last statement
993 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
995 -- Check that the last statement is the only possible return
996 -- statement in the subprogram.
998 return Check_All_Returns
(N
) = OK
;
999 end Has_Single_Return_In_GNATprove_Mode
;
1001 --------------------------
1002 -- Uses_Secondary_Stack --
1003 --------------------------
1005 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
1006 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
1007 -- Look for function calls that return an unconstrained type
1013 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
1015 if Nkind
(N
) = N_Function_Call
1016 and then Is_Entity_Name
(Name
(N
))
1017 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
1018 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
1021 ("cannot inline & (call returns unconstrained type)?",
1029 function Check_Calls
is new Traverse_Func
(Check_Call
);
1032 return Check_Calls
(Bod
) = Abandon
;
1033 end Uses_Secondary_Stack
;
1035 -- Start of processing for Build_Body_To_Inline
1038 -- Return immediately if done already
1040 if Nkind
(Decl
) = N_Subprogram_Declaration
1041 and then Present
(Body_To_Inline
(Decl
))
1045 -- Subprograms that have return statements in the middle of the body are
1046 -- inlined with gotos. GNATprove does not currently support gotos, so
1047 -- we prevent such inlining.
1049 elsif GNATprove_Mode
1050 and then not Has_Single_Return_In_GNATprove_Mode
1052 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1055 -- Functions that return unconstrained composite types require
1056 -- secondary stack handling, and cannot currently be inlined, unless
1057 -- all return statements return a local variable that is the first
1058 -- local declaration in the body.
1060 elsif Ekind
(Spec_Id
) = E_Function
1061 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1062 and then not Is_Access_Type
(Etype
(Spec_Id
))
1063 and then not Is_Constrained
(Etype
(Spec_Id
))
1065 if not Has_Single_Return
(N
) then
1067 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1071 -- Ditto for functions that return controlled types, where controlled
1072 -- actions interfere in complex ways with inlining.
1074 elsif Ekind
(Spec_Id
) = E_Function
1075 and then Needs_Finalization
(Etype
(Spec_Id
))
1078 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1082 if Present
(Declarations
(N
))
1083 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1088 if Present
(Handled_Statement_Sequence
(N
)) then
1089 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1091 ("cannot inline& (exception handler)?",
1092 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1096 elsif Has_Excluded_Statement
1097 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1103 -- We do not inline a subprogram that is too large, unless it is marked
1104 -- Inline_Always or we are in GNATprove mode. This pragma does not
1105 -- suppress the other checks on inlining (forbidden declarations,
1108 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1109 and then List_Length
1110 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1112 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1116 if Has_Pending_Instantiation
then
1118 ("cannot inline& (forward instance within enclosing body)?",
1123 -- Within an instance, the body to inline must be treated as a nested
1124 -- generic, so that the proper global references are preserved.
1126 -- Note that we do not do this at the library level, because it is not
1127 -- needed, and furthermore this causes trouble if front end inlining
1128 -- is activated (-gnatN).
1130 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1131 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1132 Original_Body
:= Copy_Generic_Node
(N
, Empty
, True);
1134 Original_Body
:= Copy_Separate_Tree
(N
);
1137 -- We need to capture references to the formals in order to substitute
1138 -- the actuals at the point of inlining, i.e. instantiation. To treat
1139 -- the formals as globals to the body to inline, we nest it within a
1140 -- dummy parameterless subprogram, declared within the real one. To
1141 -- avoid generating an internal name (which is never public, and which
1142 -- affects serial numbers of other generated names), we use an internal
1143 -- symbol that cannot conflict with user declarations.
1145 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1146 Set_Defining_Unit_Name
1147 (Specification
(Original_Body
),
1148 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1149 Set_Corresponding_Spec
(Original_Body
, Empty
);
1151 -- Remove all aspects/pragmas that have no meaining in an inlined body
1153 Remove_Aspects_And_Pragmas
(Original_Body
);
1155 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1157 -- Set return type of function, which is also global and does not need
1160 if Ekind
(Spec_Id
) = E_Function
then
1161 Set_Result_Definition
1162 (Specification
(Body_To_Analyze
),
1163 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1166 if No
(Declarations
(N
)) then
1167 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1169 Append
(Body_To_Analyze
, Declarations
(N
));
1172 -- The body to inline is pre-analyzed. In GNATprove mode we must disable
1173 -- full analysis as well so that light expansion does not take place
1174 -- either, and name resolution is unaffected.
1176 Expander_Mode_Save_And_Set
(False);
1177 Full_Analysis
:= False;
1179 Analyze
(Body_To_Analyze
);
1180 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1181 Save_Global_References
(Original_Body
);
1183 Remove
(Body_To_Analyze
);
1185 Expander_Mode_Restore
;
1186 Full_Analysis
:= Analysis_Status
;
1188 -- Restore environment if previously saved
1190 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1194 -- If secondary stack is used, there is no point in inlining. We have
1195 -- already issued the warning in this case, so nothing to do.
1197 if Uses_Secondary_Stack
(Body_To_Analyze
) then
1201 Set_Body_To_Inline
(Decl
, Original_Body
);
1202 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1203 Set_Is_Inlined
(Spec_Id
);
1204 end Build_Body_To_Inline
;
1210 procedure Cannot_Inline
1214 Is_Serious
: Boolean := False)
1217 -- In GNATprove mode, inlining is the technical means by which the
1218 -- higher-level goal of contextual analysis is reached, so issue
1219 -- messages about failure to apply contextual analysis to a
1220 -- subprogram, rather than failure to inline it.
1223 and then Msg
(Msg
'First .. Msg
'First + 12) = "cannot inline"
1226 Len1
: constant Positive :=
1227 String (String'("cannot inline"))'Length;
1228 Len2 : constant Positive :=
1229 String (String'("info: no contextual analysis of"))'Length;
1231 New_Msg
: String (1 .. Msg
'Length + Len2
- Len1
);
1234 New_Msg
(1 .. Len2
) := "info: no contextual analysis of";
1235 New_Msg
(Len2
+ 1 .. Msg
'Length + Len2
- Len1
) :=
1236 Msg
(Msg
'First + Len1
.. Msg
'Last);
1237 Cannot_Inline
(New_Msg
, N
, Subp
, Is_Serious
);
1242 pragma Assert
(Msg
(Msg
'Last) = '?');
1244 -- Legacy front end inlining model
1246 if not Back_End_Inlining
then
1248 -- Do not emit warning if this is a predefined unit which is not
1249 -- the main unit. With validity checks enabled, some predefined
1250 -- subprograms may contain nested subprograms and become ineligible
1253 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1254 and then not In_Extended_Main_Source_Unit
(Subp
)
1258 -- In GNATprove mode, issue a warning, and indicate that the
1259 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1262 elsif GNATprove_Mode
then
1263 Set_Is_Inlined_Always
(Subp
, False);
1264 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1266 elsif Has_Pragma_Inline_Always
(Subp
) then
1268 -- Remove last character (question mark) to make this into an
1269 -- error, because the Inline_Always pragma cannot be obeyed.
1271 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1273 elsif Ineffective_Inline_Warnings
then
1274 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1277 -- New semantics relying on back end inlining
1279 elsif Is_Serious
then
1281 -- Remove last character (question mark) to make this into an error.
1283 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1285 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1286 -- is not always inlined by setting flag Is_Inlined_Always to False.
1288 elsif GNATprove_Mode
then
1289 Set_Is_Inlined_Always
(Subp
, False);
1290 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1294 -- Do not emit warning if this is a predefined unit which is not
1295 -- the main unit. This behavior is currently provided for backward
1296 -- compatibility but it will be removed when we enforce the
1297 -- strictness of the new rules.
1299 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1300 and then not In_Extended_Main_Source_Unit
(Subp
)
1304 elsif Has_Pragma_Inline_Always
(Subp
) then
1306 -- Emit a warning if this is a call to a runtime subprogram
1307 -- which is located inside a generic. Previously this call
1308 -- was silently skipped.
1310 if Is_Generic_Instance
(Subp
) then
1312 Gen_P
: constant Entity_Id
:= Generic_Parent
(Parent
(Subp
));
1314 if Is_Predefined_File_Name
1315 (Unit_File_Name
(Get_Source_Unit
(Gen_P
)))
1317 Set_Is_Inlined
(Subp
, False);
1318 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1324 -- Remove last character (question mark) to make this into an
1325 -- error, because the Inline_Always pragma cannot be obeyed.
1327 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1330 Set_Is_Inlined
(Subp
, False);
1332 if Ineffective_Inline_Warnings
then
1333 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1339 --------------------------------------
1340 -- Can_Be_Inlined_In_GNATprove_Mode --
1341 --------------------------------------
1343 function Can_Be_Inlined_In_GNATprove_Mode
1344 (Spec_Id
: Entity_Id
;
1345 Body_Id
: Entity_Id
) return Boolean
1347 function Has_Formal_With_Discriminant_Dependent_Fields
1348 (Id
: Entity_Id
) return Boolean;
1349 -- Returns true if the subprogram has at least one formal parameter of
1350 -- an unconstrained record type with per-object constraints on component
1353 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1354 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1357 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1358 -- Returns True if subprogram Id defines a compilation unit
1359 -- Shouldn't this be in Sem_Aux???
1361 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean;
1362 -- Returns True if subprogram Id is defined in the visible part of a
1363 -- package specification.
1365 ---------------------------------------------------
1366 -- Has_Formal_With_Discriminant_Dependent_Fields --
1367 ---------------------------------------------------
1369 function Has_Formal_With_Discriminant_Dependent_Fields
1370 (Id
: Entity_Id
) return Boolean is
1372 function Has_Discriminant_Dependent_Component
1373 (Typ
: Entity_Id
) return Boolean;
1374 -- Determine whether unconstrained record type Typ has at least
1375 -- one component that depends on a discriminant.
1377 ------------------------------------------
1378 -- Has_Discriminant_Dependent_Component --
1379 ------------------------------------------
1381 function Has_Discriminant_Dependent_Component
1382 (Typ
: Entity_Id
) return Boolean
1387 -- Inspect all components of the record type looking for one
1388 -- that depends on a discriminant.
1390 Comp
:= First_Component
(Typ
);
1391 while Present
(Comp
) loop
1392 if Has_Discriminant_Dependent_Constraint
(Comp
) then
1396 Next_Component
(Comp
);
1400 end Has_Discriminant_Dependent_Component
;
1404 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Id
);
1406 Formal_Typ
: Entity_Id
;
1408 -- Start of processing for
1409 -- Has_Formal_With_Discriminant_Dependent_Component
1412 -- Inspect all parameters of the subprogram looking for a formal
1413 -- of an unconstrained record type with at least one discriminant
1414 -- dependent component.
1416 Formal
:= First_Formal
(Subp_Id
);
1417 while Present
(Formal
) loop
1418 Formal_Typ
:= Etype
(Formal
);
1420 if Is_Record_Type
(Formal_Typ
)
1421 and then not Is_Constrained
(Formal_Typ
)
1422 and then Has_Discriminant_Dependent_Component
(Formal_Typ
)
1427 Next_Formal
(Formal
);
1431 end Has_Formal_With_Discriminant_Dependent_Fields
;
1433 -----------------------
1434 -- Has_Some_Contract --
1435 -----------------------
1437 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean is
1441 -- A call to an expression function may precede the actual body which
1442 -- is inserted at the end of the enclosing declarations. Ensure that
1443 -- the related entity is decorated before inspecting the contract.
1445 if Is_Subprogram_Or_Generic_Subprogram
(Id
) then
1446 Items
:= Contract
(Id
);
1448 return Present
(Items
)
1449 and then (Present
(Pre_Post_Conditions
(Items
)) or else
1450 Present
(Contract_Test_Cases
(Items
)) or else
1451 Present
(Classifications
(Items
)));
1455 end Has_Some_Contract
;
1457 -----------------------------
1458 -- In_Package_Visible_Spec --
1459 -----------------------------
1461 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean is
1462 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1466 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1467 Decl
:= Parent
(Decl
);
1472 return Nkind
(P
) = N_Package_Specification
1473 and then List_Containing
(Decl
) = Visible_Declarations
(P
);
1474 end In_Package_Visible_Spec
;
1476 ------------------------
1477 -- Is_Unit_Subprogram --
1478 ------------------------
1480 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean is
1481 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1483 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1484 Decl
:= Parent
(Decl
);
1487 return Nkind
(Parent
(Decl
)) = N_Compilation_Unit
;
1488 end Is_Unit_Subprogram
;
1490 -- Local declarations
1492 Id
: Entity_Id
; -- Procedure or function entity for the subprogram
1494 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1497 pragma Assert
(Present
(Spec_Id
) or else Present
(Body_Id
));
1499 if Present
(Spec_Id
) then
1505 -- Only local subprograms without contracts are inlined in GNATprove
1506 -- mode, as these are the subprograms which a user is not interested in
1507 -- analyzing in isolation, but rather in the context of their call. This
1508 -- is a convenient convention, that could be changed for an explicit
1509 -- pragma/aspect one day.
1511 -- In a number of special cases, inlining is not desirable or not
1512 -- possible, see below.
1514 -- Do not inline unit-level subprograms
1516 if Is_Unit_Subprogram
(Id
) then
1519 -- Do not inline subprograms declared in the visible part of a package
1521 elsif In_Package_Visible_Spec
(Id
) then
1524 -- Do not inline subprograms marked No_Return, possibly used for
1525 -- signaling errors, which GNATprove handles specially.
1527 elsif No_Return
(Id
) then
1530 -- Do not inline subprograms that have a contract on the spec or the
1531 -- body. Use the contract(s) instead in GNATprove.
1533 elsif (Present
(Spec_Id
) and then Has_Some_Contract
(Spec_Id
))
1535 (Present
(Body_Id
) and then Has_Some_Contract
(Body_Id
))
1539 -- Do not inline expression functions, which are directly inlined at the
1542 elsif (Present
(Spec_Id
) and then Is_Expression_Function
(Spec_Id
))
1544 (Present
(Body_Id
) and then Is_Expression_Function
(Body_Id
))
1548 -- Do not inline generic subprogram instances. The visibility rules of
1549 -- generic instances plays badly with inlining.
1551 elsif Is_Generic_Instance
(Spec_Id
) then
1554 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1555 -- the subprogram body, a similar check is performed after the body
1556 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1558 elsif Present
(Spec_Id
)
1560 (No
(SPARK_Pragma
(Spec_Id
))
1562 Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) /= On
)
1566 -- Subprograms in generic instances are currently not inlined, to avoid
1567 -- problems with inlining of standard library subprograms.
1569 elsif Instantiation_Location
(Sloc
(Id
)) /= No_Location
then
1572 -- Do not inline predicate functions (treated specially by GNATprove)
1574 elsif Is_Predicate_Function
(Id
) then
1577 -- Do not inline subprograms with a parameter of an unconstrained
1578 -- record type if it has discrimiant dependent fields. Indeed, with
1579 -- such parameters, the frontend cannot always ensure type compliance
1580 -- in record component accesses (in particular with records containing
1583 elsif Has_Formal_With_Discriminant_Dependent_Fields
(Id
) then
1586 -- Otherwise, this is a subprogram declared inside the private part of a
1587 -- package, or inside a package body, or locally in a subprogram, and it
1588 -- does not have any contract. Inline it.
1593 end Can_Be_Inlined_In_GNATprove_Mode
;
1595 --------------------------------------------
1596 -- Check_And_Split_Unconstrained_Function --
1597 --------------------------------------------
1599 procedure Check_And_Split_Unconstrained_Function
1601 Spec_Id
: Entity_Id
;
1602 Body_Id
: Entity_Id
)
1604 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
);
1605 -- Use generic machinery to build an unexpanded body for the subprogram.
1606 -- This body is subsequently used for inline expansions at call sites.
1608 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean;
1609 -- Return true if we generate code for the function body N, the function
1610 -- body N has no local declarations and its unique statement is a single
1611 -- extended return statement with a handled statements sequence.
1613 procedure Generate_Subprogram_Body
1615 Body_To_Inline
: out Node_Id
);
1616 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1617 -- of pragmas referencing the formals are removed since they have no
1618 -- meaning when the body is inlined and the formals are rewritten (the
1619 -- analysis of the non-inlined body will handle these pragmas properly).
1620 -- A new internal name is associated with Body_To_Inline.
1622 procedure Split_Unconstrained_Function
1624 Spec_Id
: Entity_Id
);
1625 -- N is an inlined function body that returns an unconstrained type and
1626 -- has a single extended return statement. Split N in two subprograms:
1627 -- a procedure P' and a function F'. The formals of P' duplicate the
1628 -- formals of N plus an extra formal which is used return a value;
1629 -- its body is composed by the declarations and list of statements
1630 -- of the extended return statement of N.
1632 --------------------------
1633 -- Build_Body_To_Inline --
1634 --------------------------
1636 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1637 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1638 Original_Body
: Node_Id
;
1639 Body_To_Analyze
: Node_Id
;
1642 pragma Assert
(Current_Scope
= Spec_Id
);
1644 -- Within an instance, the body to inline must be treated as a nested
1645 -- generic, so that the proper global references are preserved. We
1646 -- do not do this at the library level, because it is not needed, and
1647 -- furthermore this causes trouble if front end inlining is activated
1651 and then Scope
(Current_Scope
) /= Standard_Standard
1653 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1656 -- We need to capture references to the formals in order
1657 -- to substitute the actuals at the point of inlining, i.e.
1658 -- instantiation. To treat the formals as globals to the body to
1659 -- inline, we nest it within a dummy parameterless subprogram,
1660 -- declared within the real one.
1662 Generate_Subprogram_Body
(N
, Original_Body
);
1663 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1665 -- Set return type of function, which is also global and does not
1666 -- need to be resolved.
1668 if Ekind
(Spec_Id
) = E_Function
then
1669 Set_Result_Definition
(Specification
(Body_To_Analyze
),
1670 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1673 if No
(Declarations
(N
)) then
1674 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1676 Append_To
(Declarations
(N
), Body_To_Analyze
);
1679 Preanalyze
(Body_To_Analyze
);
1681 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1682 Save_Global_References
(Original_Body
);
1684 Remove
(Body_To_Analyze
);
1686 -- Restore environment if previously saved
1689 and then Scope
(Current_Scope
) /= Standard_Standard
1694 pragma Assert
(No
(Body_To_Inline
(Decl
)));
1695 Set_Body_To_Inline
(Decl
, Original_Body
);
1696 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1697 end Build_Body_To_Inline
;
1699 --------------------------------------
1700 -- Can_Split_Unconstrained_Function --
1701 --------------------------------------
1703 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean
1705 Ret_Node
: constant Node_Id
:=
1706 First
(Statements
(Handled_Statement_Sequence
(N
)));
1710 -- No user defined declarations allowed in the function except inside
1711 -- the unique return statement; implicit labels are the only allowed
1714 if not Is_Empty_List
(Declarations
(N
)) then
1715 D
:= First
(Declarations
(N
));
1716 while Present
(D
) loop
1717 if Nkind
(D
) /= N_Implicit_Label_Declaration
then
1725 -- We only split the inlined function when we are generating the code
1726 -- of its body; otherwise we leave duplicated split subprograms in
1727 -- the tree which (if referenced) generate wrong references at link
1730 return In_Extended_Main_Code_Unit
(N
)
1731 and then Present
(Ret_Node
)
1732 and then Nkind
(Ret_Node
) = N_Extended_Return_Statement
1733 and then No
(Next
(Ret_Node
))
1734 and then Present
(Handled_Statement_Sequence
(Ret_Node
));
1735 end Can_Split_Unconstrained_Function
;
1737 -----------------------------
1738 -- Generate_Body_To_Inline --
1739 -----------------------------
1741 procedure Generate_Subprogram_Body
1743 Body_To_Inline
: out Node_Id
)
1746 -- Within an instance, the body to inline must be treated as a nested
1747 -- generic, so that the proper global references are preserved.
1749 -- Note that we do not do this at the library level, because it
1750 -- is not needed, and furthermore this causes trouble if front
1751 -- end inlining is activated (-gnatN).
1754 and then Scope
(Current_Scope
) /= Standard_Standard
1756 Body_To_Inline
:= Copy_Generic_Node
(N
, Empty
, True);
1758 Body_To_Inline
:= Copy_Separate_Tree
(N
);
1761 -- Remove all aspects/pragmas that have no meaning in an inlined body
1763 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
1765 -- We need to capture references to the formals in order
1766 -- to substitute the actuals at the point of inlining, i.e.
1767 -- instantiation. To treat the formals as globals to the body to
1768 -- inline, we nest it within a dummy parameterless subprogram,
1769 -- declared within the real one.
1771 Set_Parameter_Specifications
1772 (Specification
(Body_To_Inline
), No_List
);
1774 -- A new internal name is associated with Body_To_Inline to avoid
1775 -- conflicts when the non-inlined body N is analyzed.
1777 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
1778 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
1779 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
1780 end Generate_Subprogram_Body
;
1782 ----------------------------------
1783 -- Split_Unconstrained_Function --
1784 ----------------------------------
1786 procedure Split_Unconstrained_Function
1788 Spec_Id
: Entity_Id
)
1790 Loc
: constant Source_Ptr
:= Sloc
(N
);
1791 Ret_Node
: constant Node_Id
:=
1792 First
(Statements
(Handled_Statement_Sequence
(N
)));
1793 Ret_Obj
: constant Node_Id
:=
1794 First
(Return_Object_Declarations
(Ret_Node
));
1796 procedure Build_Procedure
1797 (Proc_Id
: out Entity_Id
;
1798 Decl_List
: out List_Id
);
1799 -- Build a procedure containing the statements found in the extended
1800 -- return statement of the unconstrained function body N.
1802 ---------------------
1803 -- Build_Procedure --
1804 ---------------------
1806 procedure Build_Procedure
1807 (Proc_Id
: out Entity_Id
;
1808 Decl_List
: out List_Id
)
1811 Formal_List
: constant List_Id
:= New_List
;
1812 Proc_Spec
: Node_Id
;
1813 Proc_Body
: Node_Id
;
1814 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
1815 Body_Decl_List
: List_Id
:= No_List
;
1816 Param_Type
: Node_Id
;
1819 if Nkind
(Object_Definition
(Ret_Obj
)) = N_Identifier
then
1821 New_Copy
(Object_Definition
(Ret_Obj
));
1824 New_Copy
(Subtype_Mark
(Object_Definition
(Ret_Obj
)));
1827 Append_To
(Formal_List
,
1828 Make_Parameter_Specification
(Loc
,
1829 Defining_Identifier
=>
1830 Make_Defining_Identifier
(Loc
,
1831 Chars
=> Chars
(Defining_Identifier
(Ret_Obj
))),
1832 In_Present
=> False,
1833 Out_Present
=> True,
1834 Null_Exclusion_Present
=> False,
1835 Parameter_Type
=> Param_Type
));
1837 Formal
:= First_Formal
(Spec_Id
);
1839 -- Note that we copy the parameter type rather than creating
1840 -- a reference to it, because it may be a class-wide entity
1841 -- that will not be retrieved by name.
1843 while Present
(Formal
) loop
1844 Append_To
(Formal_List
,
1845 Make_Parameter_Specification
(Loc
,
1846 Defining_Identifier
=>
1847 Make_Defining_Identifier
(Sloc
(Formal
),
1848 Chars
=> Chars
(Formal
)),
1849 In_Present
=> In_Present
(Parent
(Formal
)),
1850 Out_Present
=> Out_Present
(Parent
(Formal
)),
1851 Null_Exclusion_Present
=>
1852 Null_Exclusion_Present
(Parent
(Formal
)),
1854 New_Copy_Tree
(Parameter_Type
(Parent
(Formal
))),
1856 Copy_Separate_Tree
(Expression
(Parent
(Formal
)))));
1858 Next_Formal
(Formal
);
1861 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
1864 Make_Procedure_Specification
(Loc
,
1865 Defining_Unit_Name
=> Proc_Id
,
1866 Parameter_Specifications
=> Formal_List
);
1868 Decl_List
:= New_List
;
1870 Append_To
(Decl_List
,
1871 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
1873 -- Can_Convert_Unconstrained_Function checked that the function
1874 -- has no local declarations except implicit label declarations.
1875 -- Copy these declarations to the built procedure.
1877 if Present
(Declarations
(N
)) then
1878 Body_Decl_List
:= New_List
;
1885 D
:= First
(Declarations
(N
));
1886 while Present
(D
) loop
1887 pragma Assert
(Nkind
(D
) = N_Implicit_Label_Declaration
);
1890 Make_Implicit_Label_Declaration
(Loc
,
1891 Make_Defining_Identifier
(Loc
,
1892 Chars
=> Chars
(Defining_Identifier
(D
))),
1893 Label_Construct
=> Empty
);
1894 Append_To
(Body_Decl_List
, New_D
);
1901 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Node
)));
1904 Make_Subprogram_Body
(Loc
,
1905 Specification
=> Copy_Separate_Tree
(Proc_Spec
),
1906 Declarations
=> Body_Decl_List
,
1907 Handled_Statement_Sequence
=>
1908 Copy_Separate_Tree
(Handled_Statement_Sequence
(Ret_Node
)));
1910 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
1911 Make_Defining_Identifier
(Loc
, Subp_Name
));
1913 Append_To
(Decl_List
, Proc_Body
);
1914 end Build_Procedure
;
1918 New_Obj
: constant Node_Id
:= Copy_Separate_Tree
(Ret_Obj
);
1920 Proc_Id
: Entity_Id
;
1921 Proc_Call
: Node_Id
;
1923 -- Start of processing for Split_Unconstrained_Function
1926 -- Build the associated procedure, analyze it and insert it before
1927 -- the function body N.
1930 Scope
: constant Entity_Id
:= Current_Scope
;
1931 Decl_List
: List_Id
;
1934 Build_Procedure
(Proc_Id
, Decl_List
);
1935 Insert_Actions
(N
, Decl_List
);
1939 -- Build the call to the generated procedure
1942 Actual_List
: constant List_Id
:= New_List
;
1946 Append_To
(Actual_List
,
1947 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
1949 Formal
:= First_Formal
(Spec_Id
);
1950 while Present
(Formal
) loop
1951 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
1953 -- Avoid spurious warning on unreferenced formals
1955 Set_Referenced
(Formal
);
1956 Next_Formal
(Formal
);
1960 Make_Procedure_Call_Statement
(Loc
,
1961 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
1962 Parameter_Associations
=> Actual_List
);
1970 -- main_1__F1b (New_Obj, ...);
1975 Make_Block_Statement
(Loc
,
1976 Declarations
=> New_List
(New_Obj
),
1977 Handled_Statement_Sequence
=>
1978 Make_Handled_Sequence_Of_Statements
(Loc
,
1979 Statements
=> New_List
(
1983 Make_Simple_Return_Statement
(Loc
,
1986 (Defining_Identifier
(New_Obj
), Loc
)))));
1988 Rewrite
(Ret_Node
, Blk_Stmt
);
1989 end Split_Unconstrained_Function
;
1993 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1995 -- Start of processing for Check_And_Split_Unconstrained_Function
1998 pragma Assert
(Back_End_Inlining
1999 and then Ekind
(Spec_Id
) = E_Function
2000 and then Returns_Unconstrained_Type
(Spec_Id
)
2001 and then Comes_From_Source
(Body_Id
)
2002 and then (Has_Pragma_Inline_Always
(Spec_Id
)
2003 or else Optimization_Level
> 0));
2005 -- This routine must not be used in GNATprove mode since GNATprove
2006 -- relies on frontend inlining
2008 pragma Assert
(not GNATprove_Mode
);
2010 -- No need to split the function if we cannot generate the code
2012 if Serious_Errors_Detected
/= 0 then
2016 -- No action needed in stubs since the attribute Body_To_Inline
2019 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
2022 -- Cannot build the body to inline if the attribute is already set.
2023 -- This attribute may have been set if this is a subprogram renaming
2024 -- declarations (see Freeze.Build_Renamed_Body).
2026 elsif Present
(Body_To_Inline
(Decl
)) then
2029 -- Check excluded declarations
2031 elsif Present
(Declarations
(N
))
2032 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
2036 -- Check excluded statements. There is no need to protect us against
2037 -- exception handlers since they are supported by the GCC backend.
2039 elsif Present
(Handled_Statement_Sequence
(N
))
2040 and then Has_Excluded_Statement
2041 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2046 -- Build the body to inline only if really needed
2048 if Can_Split_Unconstrained_Function
(N
) then
2049 Split_Unconstrained_Function
(N
, Spec_Id
);
2050 Build_Body_To_Inline
(N
, Spec_Id
);
2051 Set_Is_Inlined
(Spec_Id
);
2053 end Check_And_Split_Unconstrained_Function
;
2055 -------------------------------------
2056 -- Check_Package_Body_For_Inlining --
2057 -------------------------------------
2059 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2060 Bname
: Unit_Name_Type
;
2065 -- Legacy implementation (relying on frontend inlining)
2067 if not Back_End_Inlining
2068 and then Is_Compilation_Unit
(P
)
2069 and then not Is_Generic_Instance
(P
)
2071 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2073 E
:= First_Entity
(P
);
2074 while Present
(E
) loop
2075 if Has_Pragma_Inline_Always
(E
)
2076 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2078 if not Is_Loaded
(Bname
) then
2079 Load_Needed_Body
(N
, OK
);
2083 -- Check we are not trying to inline a parent whose body
2084 -- depends on a child, when we are compiling the body of
2085 -- the child. Otherwise we have a potential elaboration
2086 -- circularity with inlined subprograms and with
2087 -- Taft-Amendment types.
2090 Comp
: Node_Id
; -- Body just compiled
2091 Child_Spec
: Entity_Id
; -- Spec of main unit
2092 Ent
: Entity_Id
; -- For iteration
2093 With_Clause
: Node_Id
; -- Context of body.
2096 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2097 and then Present
(Body_Entity
(P
))
2101 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2104 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2106 -- Check whether the context of the body just
2107 -- compiled includes a child of itself, and that
2108 -- child is the spec of the main compilation.
2110 With_Clause
:= First
(Context_Items
(Comp
));
2111 while Present
(With_Clause
) loop
2112 if Nkind
(With_Clause
) = N_With_Clause
2114 Scope
(Entity
(Name
(With_Clause
))) = P
2116 Entity
(Name
(With_Clause
)) = Child_Spec
2118 Error_Msg_Node_2
:= Child_Spec
;
2120 ("body of & depends on child unit&??",
2123 ("\subprograms in body cannot be inlined??",
2126 -- Disable further inlining from this unit,
2127 -- and keep Taft-amendment types incomplete.
2129 Ent
:= First_Entity
(P
);
2130 while Present
(Ent
) loop
2132 and then Has_Completion_In_Body
(Ent
)
2134 Set_Full_View
(Ent
, Empty
);
2136 elsif Is_Subprogram
(Ent
) then
2137 Set_Is_Inlined
(Ent
, False);
2151 elsif Ineffective_Inline_Warnings
then
2152 Error_Msg_Unit_1
:= Bname
;
2154 ("unable to inline subprograms defined in $??", P
);
2155 Error_Msg_N
("\body not found??", P
);
2166 end Check_Package_Body_For_Inlining
;
2168 --------------------
2169 -- Cleanup_Scopes --
2170 --------------------
2172 procedure Cleanup_Scopes
is
2178 Elmt
:= First_Elmt
(To_Clean
);
2179 while Present
(Elmt
) loop
2180 Scop
:= Node
(Elmt
);
2182 if Ekind
(Scop
) = E_Entry
then
2183 Scop
:= Protected_Body_Subprogram
(Scop
);
2185 elsif Is_Subprogram
(Scop
)
2186 and then Is_Protected_Type
(Scope
(Scop
))
2187 and then Present
(Protected_Body_Subprogram
(Scop
))
2189 -- If a protected operation contains an instance, its cleanup
2190 -- operations have been delayed, and the subprogram has been
2191 -- rewritten in the expansion of the enclosing protected body. It
2192 -- is the corresponding subprogram that may require the cleanup
2193 -- operations, so propagate the information that triggers cleanup
2197 (Protected_Body_Subprogram
(Scop
),
2198 Uses_Sec_Stack
(Scop
));
2200 Scop
:= Protected_Body_Subprogram
(Scop
);
2203 if Ekind
(Scop
) = E_Block
then
2204 Decl
:= Parent
(Block_Node
(Scop
));
2207 Decl
:= Unit_Declaration_Node
(Scop
);
2209 if Nkind_In
(Decl
, N_Subprogram_Declaration
,
2210 N_Task_Type_Declaration
,
2211 N_Subprogram_Body_Stub
)
2213 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2218 Expand_Cleanup_Actions
(Decl
);
2221 Elmt
:= Next_Elmt
(Elmt
);
2225 -------------------------
2226 -- Expand_Inlined_Call --
2227 -------------------------
2229 procedure Expand_Inlined_Call
2232 Orig_Subp
: Entity_Id
)
2234 Loc
: constant Source_Ptr
:= Sloc
(N
);
2235 Is_Predef
: constant Boolean :=
2236 Is_Predefined_File_Name
2237 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2238 Orig_Bod
: constant Node_Id
:=
2239 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2243 Decls
: constant List_Id
:= New_List
;
2244 Exit_Lab
: Entity_Id
:= Empty
;
2251 Ret_Type
: Entity_Id
;
2254 -- The target of the call. If context is an assignment statement then
2255 -- this is the left-hand side of the assignment, else it is a temporary
2256 -- to which the return value is assigned prior to rewriting the call.
2259 -- A separate target used when the return type is unconstrained
2262 Temp_Typ
: Entity_Id
;
2264 Return_Object
: Entity_Id
:= Empty
;
2265 -- Entity in declaration in an extended_return_statement
2268 Is_Unc_Decl
: Boolean;
2269 -- If the type returned by the function is unconstrained and the call
2270 -- can be inlined, special processing is required.
2272 procedure Declare_Postconditions_Result
;
2273 -- When generating C code, declare _Result, which may be used in the
2274 -- inlined _Postconditions procedure to verify the return value.
2276 procedure Make_Exit_Label
;
2277 -- Build declaration for exit label to be used in Return statements,
2278 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2279 -- declaration). Does nothing if Exit_Lab already set.
2281 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2282 -- Replace occurrence of a formal with the corresponding actual, or the
2283 -- thunk generated for it. Replace a return statement with an assignment
2284 -- to the target of the call, with appropriate conversions if needed.
2286 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2287 -- If the call being expanded is that of an internal subprogram, set the
2288 -- sloc of the generated block to that of the call itself, so that the
2289 -- expansion is skipped by the "next" command in gdb. Same processing
2290 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2291 -- Debug_Generated_Code is true, suppress this change to simplify our
2292 -- own development. Same in GNATprove mode, to ensure that warnings and
2293 -- diagnostics point to the proper location.
2295 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
2296 -- In subtree N search for occurrences of dispatching calls that use the
2297 -- Ada 2005 Object.Operation notation and the object is a formal of the
2298 -- inlined subprogram. Reset the entity associated with Operation in all
2299 -- the found occurrences.
2301 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2302 -- If the function body is a single expression, replace call with
2303 -- expression, else insert block appropriately.
2305 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2306 -- If procedure body has no local variables, inline body without
2307 -- creating block, otherwise rewrite call with block.
2309 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2310 -- Determine whether a formal parameter is used only once in Orig_Bod
2312 -----------------------------------
2313 -- Declare_Postconditions_Result --
2314 -----------------------------------
2316 procedure Declare_Postconditions_Result
is
2317 Enclosing_Subp
: constant Entity_Id
:= Scope
(Subp
);
2322 and then Is_Subprogram
(Enclosing_Subp
)
2323 and then Present
(Postconditions_Proc
(Enclosing_Subp
)));
2325 if Ekind
(Enclosing_Subp
) = E_Function
then
2326 if Nkind
(First
(Parameter_Associations
(N
)))
2327 in N_Numeric_Or_String_Literal
2329 Append_To
(Declarations
(Blk
),
2330 Make_Object_Declaration
(Loc
,
2331 Defining_Identifier
=>
2332 Make_Defining_Identifier
(Loc
, Name_uResult
),
2333 Constant_Present
=> True,
2334 Object_Definition
=>
2335 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2337 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2339 Append_To
(Declarations
(Blk
),
2340 Make_Object_Renaming_Declaration
(Loc
,
2341 Defining_Identifier
=>
2342 Make_Defining_Identifier
(Loc
, Name_uResult
),
2344 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2346 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2349 end Declare_Postconditions_Result
;
2351 ---------------------
2352 -- Make_Exit_Label --
2353 ---------------------
2355 procedure Make_Exit_Label
is
2356 Lab_Ent
: Entity_Id
;
2358 if No
(Exit_Lab
) then
2359 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
2360 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
2361 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2363 Make_Implicit_Label_Declaration
(Loc
,
2364 Defining_Identifier
=> Lab_Ent
,
2365 Label_Construct
=> Exit_Lab
);
2367 end Make_Exit_Label
;
2369 ---------------------
2370 -- Process_Formals --
2371 ---------------------
2373 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2379 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
2382 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
2383 A
:= Renamed_Object
(E
);
2385 -- Rewrite the occurrence of the formal into an occurrence of
2386 -- the actual. Also establish visibility on the proper view of
2387 -- the actual's subtype for the body's context (if the actual's
2388 -- subtype is private at the call point but its full view is
2389 -- visible to the body, then the inlined tree here must be
2390 -- analyzed with the full view).
2392 if Is_Entity_Name
(A
) then
2393 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
2394 Check_Private_View
(N
);
2396 elsif Nkind
(A
) = N_Defining_Identifier
then
2397 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
2398 Check_Private_View
(N
);
2403 Rewrite
(N
, New_Copy
(A
));
2409 elsif Is_Entity_Name
(N
)
2410 and then Present
(Return_Object
)
2411 and then Chars
(N
) = Chars
(Return_Object
)
2413 -- Occurrence within an extended return statement. The return
2414 -- object is local to the body been inlined, and thus the generic
2415 -- copy is not analyzed yet, so we match by name, and replace it
2416 -- with target of call.
2418 if Nkind
(Targ
) = N_Defining_Identifier
then
2419 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
2421 Rewrite
(N
, New_Copy_Tree
(Targ
));
2426 elsif Nkind
(N
) = N_Simple_Return_Statement
then
2427 if No
(Expression
(N
)) then
2430 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2433 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2434 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2436 -- Function body is a single expression. No need for
2442 Num_Ret
:= Num_Ret
+ 1;
2446 -- Because of the presence of private types, the views of the
2447 -- expression and the context may be different, so place an
2448 -- unchecked conversion to the context type to avoid spurious
2449 -- errors, e.g. when the expression is a numeric literal and
2450 -- the context is private. If the expression is an aggregate,
2451 -- use a qualified expression, because an aggregate is not a
2452 -- legal argument of a conversion. Ditto for numeric literals,
2453 -- which must be resolved to a specific type.
2455 if Nkind_In
(Expression
(N
), N_Aggregate
,
2461 Make_Qualified_Expression
(Sloc
(N
),
2462 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2463 Expression
=> Relocate_Node
(Expression
(N
)));
2466 Unchecked_Convert_To
2467 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2470 if Nkind
(Targ
) = N_Defining_Identifier
then
2472 Make_Assignment_Statement
(Loc
,
2473 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2474 Expression
=> Ret
));
2477 Make_Assignment_Statement
(Loc
,
2478 Name
=> New_Copy
(Targ
),
2479 Expression
=> Ret
));
2482 Set_Assignment_OK
(Name
(N
));
2484 if Present
(Exit_Lab
) then
2486 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2492 -- An extended return becomes a block whose first statement is the
2493 -- assignment of the initial expression of the return object to the
2494 -- target of the call itself.
2496 elsif Nkind
(N
) = N_Extended_Return_Statement
then
2498 Return_Decl
: constant Entity_Id
:=
2499 First
(Return_Object_Declarations
(N
));
2503 Return_Object
:= Defining_Identifier
(Return_Decl
);
2505 if Present
(Expression
(Return_Decl
)) then
2506 if Nkind
(Targ
) = N_Defining_Identifier
then
2508 Make_Assignment_Statement
(Loc
,
2509 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2510 Expression
=> Expression
(Return_Decl
));
2513 Make_Assignment_Statement
(Loc
,
2514 Name
=> New_Copy
(Targ
),
2515 Expression
=> Expression
(Return_Decl
));
2518 Set_Assignment_OK
(Name
(Assign
));
2520 if No
(Handled_Statement_Sequence
(N
)) then
2521 Set_Handled_Statement_Sequence
(N
,
2522 Make_Handled_Sequence_Of_Statements
(Loc
,
2523 Statements
=> New_List
));
2527 Statements
(Handled_Statement_Sequence
(N
)));
2531 Make_Block_Statement
(Loc
,
2532 Handled_Statement_Sequence
=>
2533 Handled_Statement_Sequence
(N
)));
2538 -- Remove pragma Unreferenced since it may refer to formals that
2539 -- are not visible in the inlined body, and in any case we will
2540 -- not be posting warnings on the inlined body so it is unneeded.
2542 elsif Nkind
(N
) = N_Pragma
2543 and then Pragma_Name
(N
) = Name_Unreferenced
2545 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2551 end Process_Formals
;
2553 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2559 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2561 if not Debug_Generated_Code
then
2562 Set_Sloc
(Nod
, Sloc
(N
));
2563 Set_Comes_From_Source
(Nod
, False);
2569 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2571 ------------------------------
2572 -- Reset_Dispatching_Calls --
2573 ------------------------------
2575 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
2577 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
2578 -- Comment required ???
2584 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
2586 if Nkind
(N
) = N_Procedure_Call_Statement
2587 and then Nkind
(Name
(N
)) = N_Selected_Component
2588 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
2589 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
2590 and then Is_Dispatching_Operation
2591 (Entity
(Selector_Name
(Name
(N
))))
2593 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
2599 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
2603 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
2604 pragma Unreferenced
(Dummy
);
2606 -- Start of processing for Reset_Dispatching_Calls
2610 end Reset_Dispatching_Calls
;
2612 ---------------------------
2613 -- Rewrite_Function_Call --
2614 ---------------------------
2616 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2617 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2618 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2621 -- Optimize simple case: function body is a single return statement,
2622 -- which has been expanded into an assignment.
2624 if Is_Empty_List
(Declarations
(Blk
))
2625 and then Nkind
(Fst
) = N_Assignment_Statement
2626 and then No
(Next
(Fst
))
2628 -- The function call may have been rewritten as the temporary
2629 -- that holds the result of the call, in which case remove the
2630 -- now useless declaration.
2632 if Nkind
(N
) = N_Identifier
2633 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2635 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2638 Rewrite
(N
, Expression
(Fst
));
2640 elsif Nkind
(N
) = N_Identifier
2641 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2643 -- The block assigns the result of the call to the temporary
2645 Insert_After
(Parent
(Entity
(N
)), Blk
);
2647 -- If the context is an assignment, and the left-hand side is free of
2648 -- side-effects, the replacement is also safe.
2649 -- Can this be generalized further???
2651 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2653 (Is_Entity_Name
(Name
(Parent
(N
)))
2655 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
2656 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
2659 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2660 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
2662 -- Replace assignment with the block
2665 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2668 -- Preserve the original assignment node to keep the complete
2669 -- assignment subtree consistent enough for Analyze_Assignment
2670 -- to proceed (specifically, the original Lhs node must still
2671 -- have an assignment statement as its parent).
2673 -- We cannot rely on Original_Node to go back from the block
2674 -- node to the assignment node, because the assignment might
2675 -- already be a rewrite substitution.
2677 Discard_Node
(Relocate_Node
(Original_Assignment
));
2678 Rewrite
(Original_Assignment
, Blk
);
2681 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2683 -- A call to a function which returns an unconstrained type
2684 -- found in the expression initializing an object-declaration is
2685 -- expanded into a procedure call which must be added after the
2686 -- object declaration.
2688 if Is_Unc_Decl
and Back_End_Inlining
then
2689 Insert_Action_After
(Parent
(N
), Blk
);
2691 Set_Expression
(Parent
(N
), Empty
);
2692 Insert_After
(Parent
(N
), Blk
);
2695 elsif Is_Unc
and then not Back_End_Inlining
then
2696 Insert_Before
(Parent
(N
), Blk
);
2698 end Rewrite_Function_Call
;
2700 ----------------------------
2701 -- Rewrite_Procedure_Call --
2702 ----------------------------
2704 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2705 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2708 -- If there is a transient scope for N, this will be the scope of the
2709 -- actions for N, and the statements in Blk need to be within this
2710 -- scope. For example, they need to have visibility on the constant
2711 -- declarations created for the formals.
2713 -- If N needs no transient scope, and if there are no declarations in
2714 -- the inlined body, we can do a little optimization and insert the
2715 -- statements for the body directly after N, and rewrite N to a
2716 -- null statement, instead of rewriting N into a full-blown block
2719 if not Scope_Is_Transient
2720 and then Is_Empty_List
(Declarations
(Blk
))
2722 Insert_List_After
(N
, Statements
(HSS
));
2723 Rewrite
(N
, Make_Null_Statement
(Loc
));
2727 end Rewrite_Procedure_Call
;
2729 -------------------------
2730 -- Formal_Is_Used_Once --
2731 -------------------------
2733 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2734 Use_Counter
: Int
:= 0;
2736 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2737 -- Traverse the tree and count the uses of the formal parameter.
2738 -- In this case, for optimization purposes, we do not need to
2739 -- continue the traversal once more than one use is encountered.
2745 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2747 -- The original node is an identifier
2749 if Nkind
(N
) = N_Identifier
2750 and then Present
(Entity
(N
))
2752 -- Original node's entity points to the one in the copied body
2754 and then Nkind
(Entity
(N
)) = N_Identifier
2755 and then Present
(Entity
(Entity
(N
)))
2757 -- The entity of the copied node is the formal parameter
2759 and then Entity
(Entity
(N
)) = Formal
2761 Use_Counter
:= Use_Counter
+ 1;
2763 if Use_Counter
> 1 then
2765 -- Denote more than one use and abandon the traversal
2776 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2778 -- Start of processing for Formal_Is_Used_Once
2781 Count_Formal_Uses
(Orig_Bod
);
2782 return Use_Counter
= 1;
2783 end Formal_Is_Used_Once
;
2785 -- Start of processing for Expand_Inlined_Call
2788 -- Initializations for old/new semantics
2790 if not Back_End_Inlining
then
2791 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
2792 and then not Is_Constrained
(Etype
(Subp
));
2793 Is_Unc_Decl
:= False;
2795 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
2796 and then Optimization_Level
> 0;
2797 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
2801 -- Check for an illegal attempt to inline a recursive procedure. If the
2802 -- subprogram has parameters this is detected when trying to supply a
2803 -- binding for parameters that already have one. For parameterless
2804 -- subprograms this must be done explicitly.
2806 if In_Open_Scopes
(Subp
) then
2808 ("cannot inline call to recursive subprogram?", N
, Subp
);
2809 Set_Is_Inlined
(Subp
, False);
2812 -- Skip inlining if this is not a true inlining since the attribute
2813 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2814 -- true inlining, Orig_Bod has code rather than being an entity.
2816 elsif Nkind
(Orig_Bod
) in N_Entity
then
2819 -- Skip inlining if the function returns an unconstrained type using
2820 -- an extended return statement since this part of the new inlining
2821 -- model which is not yet supported by the current implementation. ???
2825 Nkind
(First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2826 N_Extended_Return_Statement
2827 and then not Back_End_Inlining
2832 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2833 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2835 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2836 -- can be replaced with calls to the renamed entity directly, because
2837 -- the subprograms are subtype conformant. If the renamed subprogram
2838 -- is an inherited operation, we must redo the expansion because
2839 -- implicit conversions may be needed. Similarly, if the renamed
2840 -- entity is inlined, expand the call for further optimizations.
2842 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2844 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
2851 -- Register the call in the list of inlined calls
2853 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
2855 -- Use generic machinery to copy body of inlined subprogram, as if it
2856 -- were an instantiation, resetting source locations appropriately, so
2857 -- that nested inlined calls appear in the main unit.
2859 Save_Env
(Subp
, Empty
);
2860 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2864 if not Back_End_Inlining
then
2869 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2871 Make_Block_Statement
(Loc
,
2872 Declarations
=> Declarations
(Bod
),
2873 Handled_Statement_Sequence
=>
2874 Handled_Statement_Sequence
(Bod
));
2876 if No
(Declarations
(Bod
)) then
2877 Set_Declarations
(Blk
, New_List
);
2880 -- When generating C code, declare _Result, which may be used to
2881 -- verify the return value.
2883 if Modify_Tree_For_C
2884 and then Nkind
(N
) = N_Procedure_Call_Statement
2885 and then Chars
(Name
(N
)) = Name_uPostconditions
2887 Declare_Postconditions_Result
;
2890 -- For the unconstrained case, capture the name of the local
2891 -- variable that holds the result. This must be the first
2892 -- declaration in the block, because its bounds cannot depend
2893 -- on local variables. Otherwise there is no way to declare the
2894 -- result outside of the block. Needless to say, in general the
2895 -- bounds will depend on the actuals in the call.
2897 -- If the context is an assignment statement, as is the case
2898 -- for the expansion of an extended return, the left-hand side
2899 -- provides bounds even if the return type is unconstrained.
2903 First_Decl
: Node_Id
;
2906 First_Decl
:= First
(Declarations
(Blk
));
2908 if Nkind
(First_Decl
) /= N_Object_Declaration
then
2912 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2913 Targ1
:= Defining_Identifier
(First_Decl
);
2915 Targ1
:= Name
(Parent
(N
));
2932 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2934 Make_Block_Statement
(Loc
,
2935 Declarations
=> Declarations
(Bod
),
2936 Handled_Statement_Sequence
=>
2937 Handled_Statement_Sequence
(Bod
));
2939 -- Inline a call to a function that returns an unconstrained type.
2940 -- The semantic analyzer checked that frontend-inlined functions
2941 -- returning unconstrained types have no declarations and have
2942 -- a single extended return statement. As part of its processing
2943 -- the function was split in two subprograms: a procedure P and
2944 -- a function F that has a block with a call to procedure P (see
2945 -- Split_Unconstrained_Function).
2951 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2955 Blk_Stmt
: constant Node_Id
:=
2956 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
2957 First_Stmt
: constant Node_Id
:=
2958 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
2959 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
2963 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
2964 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
2965 and then No
(Next
(Second_Stmt
)));
2970 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
2971 Empty
, Instantiating
=> True);
2974 -- Capture the name of the local variable that holds the
2975 -- result. This must be the first declaration in the block,
2976 -- because its bounds cannot depend on local variables.
2977 -- Otherwise there is no way to declare the result outside
2978 -- of the block. Needless to say, in general the bounds will
2979 -- depend on the actuals in the call.
2981 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2982 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
2984 -- If the context is an assignment statement, as is the case
2985 -- for the expansion of an extended return, the left-hand
2986 -- side provides bounds even if the return type is
2990 Targ1
:= Name
(Parent
(N
));
2995 if No
(Declarations
(Bod
)) then
2996 Set_Declarations
(Blk
, New_List
);
3001 -- If this is a derived function, establish the proper return type
3003 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
3004 Ret_Type
:= Etype
(Orig_Subp
);
3006 Ret_Type
:= Etype
(Subp
);
3009 -- Create temporaries for the actuals that are expressions, or that are
3010 -- scalars and require copying to preserve semantics.
3012 F
:= First_Formal
(Subp
);
3013 A
:= First_Actual
(N
);
3014 while Present
(F
) loop
3015 if Present
(Renamed_Object
(F
)) then
3017 -- If expander is active, it is an error to try to inline a
3018 -- recursive program. In GNATprove mode, just indicate that the
3019 -- inlining will not happen, and mark the subprogram as not always
3022 if GNATprove_Mode
then
3024 ("cannot inline call to recursive subprogram?", N
, Subp
);
3025 Set_Is_Inlined_Always
(Subp
, False);
3028 ("cannot inline call to recursive subprogram", N
);
3034 -- Reset Last_Assignment for any parameters of mode out or in out, to
3035 -- prevent spurious warnings about overwriting for assignments to the
3036 -- formal in the inlined code.
3038 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
3039 Set_Last_Assignment
(Entity
(A
), Empty
);
3042 -- If the argument may be a controlling argument in a call within
3043 -- the inlined body, we must preserve its classwide nature to insure
3044 -- that dynamic dispatching take place subsequently. If the formal
3045 -- has a constraint it must be preserved to retain the semantics of
3048 if Is_Class_Wide_Type
(Etype
(F
))
3049 or else (Is_Access_Type
(Etype
(F
))
3050 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3052 Temp_Typ
:= Etype
(F
);
3054 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3055 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3057 Temp_Typ
:= Etype
(F
);
3059 Temp_Typ
:= Etype
(A
);
3062 -- If the actual is a simple name or a literal, no need to
3063 -- create a temporary, object can be used directly.
3065 -- If the actual is a literal and the formal has its address taken,
3066 -- we cannot pass the literal itself as an argument, so its value
3067 -- must be captured in a temporary.
3069 if (Is_Entity_Name
(A
)
3071 (not Is_Scalar_Type
(Etype
(A
))
3072 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3074 -- When the actual is an identifier and the corresponding formal is
3075 -- used only once in the original body, the formal can be substituted
3076 -- directly with the actual parameter.
3078 or else (Nkind
(A
) = N_Identifier
3079 and then Formal_Is_Used_Once
(F
))
3082 (Nkind_In
(A
, N_Real_Literal
,
3084 N_Character_Literal
)
3085 and then not Address_Taken
(F
))
3087 if Etype
(F
) /= Etype
(A
) then
3089 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3091 Set_Renamed_Object
(F
, A
);
3095 Temp
:= Make_Temporary
(Loc
, 'C');
3097 -- If the actual for an in/in-out parameter is a view conversion,
3098 -- make it into an unchecked conversion, given that an untagged
3099 -- type conversion is not a proper object for a renaming.
3101 -- In-out conversions that involve real conversions have already
3102 -- been transformed in Expand_Actuals.
3104 if Nkind
(A
) = N_Type_Conversion
3105 and then Ekind
(F
) /= E_In_Parameter
3108 Make_Unchecked_Type_Conversion
(Loc
,
3109 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3110 Expression
=> Relocate_Node
(Expression
(A
)));
3112 elsif Etype
(F
) /= Etype
(A
) then
3113 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3114 Temp_Typ
:= Etype
(F
);
3117 New_A
:= Relocate_Node
(A
);
3120 Set_Sloc
(New_A
, Sloc
(N
));
3122 -- If the actual has a by-reference type, it cannot be copied,
3123 -- so its value is captured in a renaming declaration. Otherwise
3124 -- declare a local constant initialized with the actual.
3126 -- We also use a renaming declaration for expressions of an array
3127 -- type that is not bit-packed, both for efficiency reasons and to
3128 -- respect the semantics of the call: in most cases the original
3129 -- call will pass the parameter by reference, and thus the inlined
3130 -- code will have the same semantics.
3132 -- Finally, we need a renaming declaration in the case of limited
3133 -- types for which initialization cannot be by copy either.
3135 if Ekind
(F
) = E_In_Parameter
3136 and then not Is_By_Reference_Type
(Etype
(A
))
3137 and then not Is_Limited_Type
(Etype
(A
))
3139 (not Is_Array_Type
(Etype
(A
))
3140 or else not Is_Object_Reference
(A
)
3141 or else Is_Bit_Packed_Array
(Etype
(A
)))
3144 Make_Object_Declaration
(Loc
,
3145 Defining_Identifier
=> Temp
,
3146 Constant_Present
=> True,
3147 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3148 Expression
=> New_A
);
3151 Make_Object_Renaming_Declaration
(Loc
,
3152 Defining_Identifier
=> Temp
,
3153 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3157 Append
(Decl
, Decls
);
3158 Set_Renamed_Object
(F
, Temp
);
3165 -- Establish target of function call. If context is not assignment or
3166 -- declaration, create a temporary as a target. The declaration for the
3167 -- temporary may be subsequently optimized away if the body is a single
3168 -- expression, or if the left-hand side of the assignment is simple
3169 -- enough, i.e. an entity or an explicit dereference of one.
3171 if Ekind
(Subp
) = E_Function
then
3172 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3173 and then Is_Entity_Name
(Name
(Parent
(N
)))
3175 Targ
:= Name
(Parent
(N
));
3177 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3178 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3179 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3181 Targ
:= Name
(Parent
(N
));
3183 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3184 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3185 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3187 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3189 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3190 and then Is_Limited_Type
(Etype
(Subp
))
3192 Targ
:= Defining_Identifier
(Parent
(N
));
3194 -- New semantics: In an object declaration avoid an extra copy
3195 -- of the result of a call to an inlined function that returns
3196 -- an unconstrained type
3198 elsif Back_End_Inlining
3199 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3202 Targ
:= Defining_Identifier
(Parent
(N
));
3205 -- Replace call with temporary and create its declaration
3207 Temp
:= Make_Temporary
(Loc
, 'C');
3208 Set_Is_Internal
(Temp
);
3210 -- For the unconstrained case, the generated temporary has the
3211 -- same constrained declaration as the result variable. It may
3212 -- eventually be possible to remove that temporary and use the
3213 -- result variable directly.
3215 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3218 Make_Object_Declaration
(Loc
,
3219 Defining_Identifier
=> Temp
,
3220 Object_Definition
=>
3221 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3223 Replace_Formals
(Decl
);
3227 Make_Object_Declaration
(Loc
,
3228 Defining_Identifier
=> Temp
,
3229 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
3231 Set_Etype
(Temp
, Ret_Type
);
3234 Set_No_Initialization
(Decl
);
3235 Append
(Decl
, Decls
);
3236 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3241 Insert_Actions
(N
, Decls
);
3245 -- Special management for inlining a call to a function that returns
3246 -- an unconstrained type and initializes an object declaration: we
3247 -- avoid generating undesired extra calls and goto statements.
3250 -- function Func (...) return ...
3253 -- Result : String (1 .. 4);
3255 -- Proc (Result, ...);
3260 -- Result : String := Func (...);
3262 -- Replace this object declaration by:
3264 -- Result : String (1 .. 4);
3265 -- Proc (Result, ...);
3267 Remove_Homonym
(Targ
);
3270 Make_Object_Declaration
3272 Defining_Identifier
=> Targ
,
3273 Object_Definition
=>
3274 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3275 Replace_Formals
(Decl
);
3276 Rewrite
(Parent
(N
), Decl
);
3277 Analyze
(Parent
(N
));
3279 -- Avoid spurious warnings since we know that this declaration is
3280 -- referenced by the procedure call.
3282 Set_Never_Set_In_Source
(Targ
, False);
3284 -- Remove the local declaration of the extended return stmt from the
3287 Remove
(Parent
(Targ1
));
3289 -- Update the reference to the result (since we have rewriten the
3290 -- object declaration)
3293 Blk_Call_Stmt
: Node_Id
;
3296 -- Capture the call to the procedure
3299 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3301 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
3303 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
3304 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
3305 New_Occurrence_Of
(Targ
, Loc
));
3308 -- Remove the return statement
3311 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3312 N_Simple_Return_Statement
);
3314 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3317 -- Traverse the tree and replace formals with actuals or their thunks.
3318 -- Attach block to tree before analysis and rewriting.
3320 Replace_Formals
(Blk
);
3321 Set_Parent
(Blk
, N
);
3323 if GNATprove_Mode
then
3326 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
3332 -- No action needed since return statement has been already removed
3336 elsif Present
(Exit_Lab
) then
3338 -- If the body was a single expression, the single return statement
3339 -- and the corresponding label are useless.
3343 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3346 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3348 Append
(Lab_Decl
, (Declarations
(Blk
)));
3349 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3353 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3354 -- on conflicting private views that Gigi would ignore. If this is a
3355 -- predefined unit, analyze with checks off, as is done in the non-
3356 -- inlined run-time units.
3359 I_Flag
: constant Boolean := In_Inlined_Body
;
3362 In_Inlined_Body
:= True;
3366 Style
: constant Boolean := Style_Check
;
3369 Style_Check
:= False;
3371 -- Search for dispatching calls that use the Object.Operation
3372 -- notation using an Object that is a parameter of the inlined
3373 -- function. We reset the decoration of Operation to force
3374 -- the reanalysis of the inlined dispatching call because
3375 -- the actual object has been inlined.
3377 Reset_Dispatching_Calls
(Blk
);
3379 Analyze
(Blk
, Suppress
=> All_Checks
);
3380 Style_Check
:= Style
;
3387 In_Inlined_Body
:= I_Flag
;
3390 if Ekind
(Subp
) = E_Procedure
then
3391 Rewrite_Procedure_Call
(N
, Blk
);
3394 Rewrite_Function_Call
(N
, Blk
);
3399 -- For the unconstrained case, the replacement of the call has been
3400 -- made prior to the complete analysis of the generated declarations.
3401 -- Propagate the proper type now.
3404 if Nkind
(N
) = N_Identifier
then
3405 Set_Etype
(N
, Etype
(Entity
(N
)));
3407 Set_Etype
(N
, Etype
(Targ1
));
3414 -- Cleanup mapping between formals and actuals for other expansions
3416 F
:= First_Formal
(Subp
);
3417 while Present
(F
) loop
3418 Set_Renamed_Object
(F
, Empty
);
3421 end Expand_Inlined_Call
;
3423 --------------------------
3424 -- Get_Code_Unit_Entity --
3425 --------------------------
3427 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
3428 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
3431 if Ekind
(Unit
) = E_Package_Body
then
3432 Unit
:= Spec_Entity
(Unit
);
3436 end Get_Code_Unit_Entity
;
3438 ------------------------------
3439 -- Has_Excluded_Declaration --
3440 ------------------------------
3442 function Has_Excluded_Declaration
3444 Decls
: List_Id
) return Boolean
3448 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
3449 -- Nested subprograms make a given body ineligible for inlining, but
3450 -- we make an exception for instantiations of unchecked conversion.
3451 -- The body has not been analyzed yet, so check the name, and verify
3452 -- that the visible entity with that name is the predefined unit.
3454 -----------------------------
3455 -- Is_Unchecked_Conversion --
3456 -----------------------------
3458 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
3459 Id
: constant Node_Id
:= Name
(D
);
3463 if Nkind
(Id
) = N_Identifier
3464 and then Chars
(Id
) = Name_Unchecked_Conversion
3466 Conv
:= Current_Entity
(Id
);
3468 elsif Nkind_In
(Id
, N_Selected_Component
, N_Expanded_Name
)
3469 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
3471 Conv
:= Current_Entity
(Selector_Name
(Id
));
3476 return Present
(Conv
)
3477 and then Is_Predefined_File_Name
3478 (Unit_File_Name
(Get_Source_Unit
(Conv
)))
3479 and then Is_Intrinsic_Subprogram
(Conv
);
3480 end Is_Unchecked_Conversion
;
3482 -- Start of processing for Has_Excluded_Declaration
3485 -- No action needed if the check is not needed
3487 if not Check_Inlining_Restrictions
then
3492 while Present
(D
) loop
3494 -- First declarations universally excluded
3496 if Nkind
(D
) = N_Package_Declaration
then
3498 ("cannot inline & (nested package declaration)?", D
, Subp
);
3501 elsif Nkind
(D
) = N_Package_Instantiation
then
3503 ("cannot inline & (nested package instantiation)?", D
, Subp
);
3507 -- Then declarations excluded only for front end inlining
3509 if Back_End_Inlining
then
3512 elsif Nkind
(D
) = N_Task_Type_Declaration
3513 or else Nkind
(D
) = N_Single_Task_Declaration
3516 ("cannot inline & (nested task type declaration)?", D
, Subp
);
3519 elsif Nkind
(D
) = N_Protected_Type_Declaration
3520 or else Nkind
(D
) = N_Single_Protected_Declaration
3523 ("cannot inline & (nested protected type declaration)?",
3527 elsif Nkind
(D
) = N_Subprogram_Body
then
3529 ("cannot inline & (nested subprogram)?", D
, Subp
);
3532 elsif Nkind
(D
) = N_Function_Instantiation
3533 and then not Is_Unchecked_Conversion
(D
)
3536 ("cannot inline & (nested function instantiation)?", D
, Subp
);
3539 elsif Nkind
(D
) = N_Procedure_Instantiation
then
3541 ("cannot inline & (nested procedure instantiation)?", D
, Subp
);
3544 -- Subtype declarations with predicates will generate predicate
3545 -- functions, i.e. nested subprogram bodies, so inlining is not
3548 elsif Nkind
(D
) = N_Subtype_Declaration
3549 and then Present
(Aspect_Specifications
(D
))
3556 A
:= First
(Aspect_Specifications
(D
));
3557 while Present
(A
) loop
3558 A_Id
:= Get_Aspect_Id
(Chars
(Identifier
(A
)));
3560 if A_Id
= Aspect_Predicate
3561 or else A_Id
= Aspect_Static_Predicate
3562 or else A_Id
= Aspect_Dynamic_Predicate
3565 ("cannot inline & (subtype declaration with "
3566 & "predicate)?", D
, Subp
);
3579 end Has_Excluded_Declaration
;
3581 ----------------------------
3582 -- Has_Excluded_Statement --
3583 ----------------------------
3585 function Has_Excluded_Statement
3587 Stats
: List_Id
) return Boolean
3593 -- No action needed if the check is not needed
3595 if not Check_Inlining_Restrictions
then
3600 while Present
(S
) loop
3601 if Nkind_In
(S
, N_Abort_Statement
,
3602 N_Asynchronous_Select
,
3603 N_Conditional_Entry_Call
,
3604 N_Delay_Relative_Statement
,
3605 N_Delay_Until_Statement
,
3610 ("cannot inline & (non-allowed statement)?", S
, Subp
);
3613 elsif Nkind
(S
) = N_Block_Statement
then
3614 if Present
(Declarations
(S
))
3615 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
3619 elsif Present
(Handled_Statement_Sequence
(S
)) then
3620 if not Back_End_Inlining
3623 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
3626 ("cannot inline& (exception handler)?",
3627 First
(Exception_Handlers
3628 (Handled_Statement_Sequence
(S
))),
3632 elsif Has_Excluded_Statement
3633 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3639 elsif Nkind
(S
) = N_Case_Statement
then
3640 E
:= First
(Alternatives
(S
));
3641 while Present
(E
) loop
3642 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
3649 elsif Nkind
(S
) = N_If_Statement
then
3650 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
3654 if Present
(Elsif_Parts
(S
)) then
3655 E
:= First
(Elsif_Parts
(S
));
3656 while Present
(E
) loop
3657 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
3665 if Present
(Else_Statements
(S
))
3666 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
3671 elsif Nkind
(S
) = N_Loop_Statement
3672 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
3676 elsif Nkind
(S
) = N_Extended_Return_Statement
then
3677 if Present
(Handled_Statement_Sequence
(S
))
3679 Has_Excluded_Statement
3680 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3684 elsif not Back_End_Inlining
3685 and then Present
(Handled_Statement_Sequence
(S
))
3687 Present
(Exception_Handlers
3688 (Handled_Statement_Sequence
(S
)))
3691 ("cannot inline& (exception handler)?",
3692 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
3702 end Has_Excluded_Statement
;
3704 --------------------------
3705 -- Has_Initialized_Type --
3706 --------------------------
3708 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
3709 E_Body
: constant Node_Id
:= Subprogram_Body
(E
);
3713 if No
(E_Body
) then -- imported subprogram
3717 Decl
:= First
(Declarations
(E_Body
));
3718 while Present
(Decl
) loop
3719 if Nkind
(Decl
) = N_Full_Type_Declaration
3720 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
3730 end Has_Initialized_Type
;
3732 -----------------------
3733 -- Has_Single_Return --
3734 -----------------------
3736 function Has_Single_Return
(N
: Node_Id
) return Boolean is
3737 Return_Statement
: Node_Id
:= Empty
;
3739 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
3745 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
3747 if Nkind
(N
) = N_Simple_Return_Statement
then
3748 if Present
(Expression
(N
))
3749 and then Is_Entity_Name
(Expression
(N
))
3751 if No
(Return_Statement
) then
3752 Return_Statement
:= N
;
3755 elsif Chars
(Expression
(N
)) =
3756 Chars
(Expression
(Return_Statement
))
3764 -- A return statement within an extended return is a noop
3767 elsif No
(Expression
(N
))
3769 Nkind
(Parent
(Parent
(N
))) = N_Extended_Return_Statement
3774 -- Expression has wrong form
3779 -- We can only inline a build-in-place function if it has a single
3782 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3783 if No
(Return_Statement
) then
3784 Return_Statement
:= N
;
3796 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
3798 -- Start of processing for Has_Single_Return
3801 if Check_All_Returns
(N
) /= OK
then
3804 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
3808 return Present
(Declarations
(N
))
3809 and then Present
(First
(Declarations
(N
)))
3810 and then Chars
(Expression
(Return_Statement
)) =
3811 Chars
(Defining_Identifier
(First
(Declarations
(N
))));
3813 end Has_Single_Return
;
3815 -----------------------------
3816 -- In_Main_Unit_Or_Subunit --
3817 -----------------------------
3819 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
3820 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
3823 -- Check whether the subprogram or package to inline is within the main
3824 -- unit or its spec or within a subunit. In either case there are no
3825 -- additional bodies to process. If the subprogram appears in a parent
3826 -- of the current unit, the check on whether inlining is possible is
3827 -- done in Analyze_Inlined_Bodies.
3829 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
3830 Comp
:= Library_Unit
(Comp
);
3833 return Comp
= Cunit
(Main_Unit
)
3834 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
3835 end In_Main_Unit_Or_Subunit
;
3841 procedure Initialize
is
3843 Pending_Descriptor
.Init
;
3844 Pending_Instantiations
.Init
;
3845 Inlined_Bodies
.Init
;
3849 for J
in Hash_Headers
'Range loop
3850 Hash_Headers
(J
) := No_Subp
;
3853 Inlined_Calls
:= No_Elist
;
3854 Backend_Calls
:= No_Elist
;
3855 Backend_Inlined_Subps
:= No_Elist
;
3856 Backend_Not_Inlined_Subps
:= No_Elist
;
3859 ------------------------
3860 -- Instantiate_Bodies --
3861 ------------------------
3863 -- Generic bodies contain all the non-local references, so an
3864 -- instantiation does not need any more context than Standard
3865 -- itself, even if the instantiation appears in an inner scope.
3866 -- Generic associations have verified that the contract model is
3867 -- satisfied, so that any error that may occur in the analysis of
3868 -- the body is an internal error.
3870 procedure Instantiate_Bodies
is
3872 Info
: Pending_Body_Info
;
3875 if Serious_Errors_Detected
= 0 then
3876 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
3877 Push_Scope
(Standard_Standard
);
3878 To_Clean
:= New_Elmt_List
;
3880 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3884 -- A body instantiation may generate additional instantiations, so
3885 -- the following loop must scan to the end of a possibly expanding
3886 -- set (that's why we can't simply use a FOR loop here).
3889 while J
<= Pending_Instantiations
.Last
3890 and then Serious_Errors_Detected
= 0
3892 Info
:= Pending_Instantiations
.Table
(J
);
3894 -- If the instantiation node is absent, it has been removed
3895 -- as part of unreachable code.
3897 if No
(Info
.Inst_Node
) then
3900 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
3901 Instantiate_Package_Body
(Info
);
3902 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
3905 Instantiate_Subprogram_Body
(Info
);
3911 -- Reset the table of instantiations. Additional instantiations
3912 -- may be added through inlining, when additional bodies are
3915 Pending_Instantiations
.Init
;
3917 -- We can now complete the cleanup actions of scopes that contain
3918 -- pending instantiations (skipped for generic units, since we
3919 -- never need any cleanups in generic units).
3922 and then not Is_Generic_Unit
(Main_Unit_Entity
)
3925 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3931 end Instantiate_Bodies
;
3937 function Is_Nested
(E
: Entity_Id
) return Boolean is
3942 while Scop
/= Standard_Standard
loop
3943 if Ekind
(Scop
) in Subprogram_Kind
then
3946 elsif Ekind
(Scop
) = E_Task_Type
3947 or else Ekind
(Scop
) = E_Entry
3948 or else Ekind
(Scop
) = E_Entry_Family
3953 Scop
:= Scope
(Scop
);
3959 ------------------------
3960 -- List_Inlining_Info --
3961 ------------------------
3963 procedure List_Inlining_Info
is
3969 if not Debug_Flag_Dot_J
then
3973 -- Generate listing of calls inlined by the frontend
3975 if Present
(Inlined_Calls
) then
3977 Elmt
:= First_Elmt
(Inlined_Calls
);
3978 while Present
(Elmt
) loop
3981 if In_Extended_Main_Code_Unit
(Nod
) then
3985 Write_Str
("List of calls inlined by the frontend");
3992 Write_Location
(Sloc
(Nod
));
4001 -- Generate listing of calls passed to the backend
4003 if Present
(Backend_Calls
) then
4006 Elmt
:= First_Elmt
(Backend_Calls
);
4007 while Present
(Elmt
) loop
4010 if In_Extended_Main_Code_Unit
(Nod
) then
4014 Write_Str
("List of inlined calls passed to the backend");
4021 Write_Location
(Sloc
(Nod
));
4029 -- Generate listing of subprograms passed to the backend
4031 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
4034 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
4035 while Present
(Elmt
) loop
4042 ("List of inlined subprograms passed to the backend");
4049 Write_Name
(Chars
(Nod
));
4051 Write_Location
(Sloc
(Nod
));
4059 -- Generate listing of subprograms that cannot be inlined by the backend
4061 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
4064 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
4065 while Present
(Elmt
) loop
4072 ("List of subprograms that cannot be inlined by the backend");
4079 Write_Name
(Chars
(Nod
));
4081 Write_Location
(Sloc
(Nod
));
4088 end List_Inlining_Info
;
4096 Pending_Instantiations
.Locked
:= True;
4097 Inlined_Bodies
.Locked
:= True;
4098 Successors
.Locked
:= True;
4099 Inlined
.Locked
:= True;
4100 Pending_Instantiations
.Release
;
4101 Inlined_Bodies
.Release
;
4106 --------------------------------
4107 -- Remove_Aspects_And_Pragmas --
4108 --------------------------------
4110 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
4111 procedure Remove_Items
(List
: List_Id
);
4112 -- Remove all useless aspects/pragmas from a particular list
4118 procedure Remove_Items
(List
: List_Id
) is
4121 Next_Item
: Node_Id
;
4124 -- Traverse the list looking for an aspect specification or a pragma
4126 Item
:= First
(List
);
4127 while Present
(Item
) loop
4128 Next_Item
:= Next
(Item
);
4130 if Nkind
(Item
) = N_Aspect_Specification
then
4131 Item_Id
:= Identifier
(Item
);
4132 elsif Nkind
(Item
) = N_Pragma
then
4133 Item_Id
:= Pragma_Identifier
(Item
);
4138 if Present
(Item_Id
)
4139 and then Nam_In
(Chars
(Item_Id
), Name_Contract_Cases
,
4144 Name_Refined_Global
,
4145 Name_Refined_Depends
,
4158 -- Start of processing for Remove_Aspects_And_Pragmas
4161 Remove_Items
(Aspect_Specifications
(Body_Decl
));
4162 Remove_Items
(Declarations
(Body_Decl
));
4163 end Remove_Aspects_And_Pragmas
;
4165 --------------------------
4166 -- Remove_Dead_Instance --
4167 --------------------------
4169 procedure Remove_Dead_Instance
(N
: Node_Id
) is
4174 while J
<= Pending_Instantiations
.Last
loop
4175 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
4176 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
4182 end Remove_Dead_Instance
;