1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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
)
413 and then Is_Predefined_Unit
(Get_Source_Unit
(E
))
415 Set_Needs_Debug_Info
(E
, False);
418 -- If the subprogram is an expression function, then there is no need to
419 -- load any package body since the body of the function is in the spec.
421 if Is_Expression_Function
(E
) then
426 -- Find unit containing E, and add to list of inlined bodies if needed.
427 -- If the body is already present, no need to load any other unit. This
428 -- is the case for an initialization procedure, which appears in the
429 -- package declaration that contains the type. It is also the case if
430 -- the body has already been analyzed. Finally, if the unit enclosing
431 -- E is an instance, the instance body will be analyzed in any case,
432 -- and there is no need to add the enclosing unit (whose body might not
435 -- Library-level functions must be handled specially, because there is
436 -- no enclosing package to retrieve. In this case, it is the body of
437 -- the function that will have to be loaded.
440 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
445 Inlined_Bodies
.Increment_Last
;
446 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
448 elsif Ekind
(Pack
) = E_Package
then
451 if Is_Generic_Instance
(Pack
) then
454 -- Do not inline the package if the subprogram is an init proc
455 -- or other internally generated subprogram, because in that
456 -- case the subprogram body appears in the same unit that
457 -- declares the type, and that body is visible to the back end.
458 -- Do not inline it either if it is in the main unit.
459 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
460 -- calls if the back-end takes care of inlining the call.
461 -- Note that Level in Inline_Package | Inline_Call here.
463 elsif ((Level
= Inline_Call
464 and then Has_Pragma_Inline_Always
(E
)
465 and then Back_End_Inlining
)
466 or else Level
= Inline_Package
)
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 -- Start of processing for Analyze_Inlined_Bodies
673 if Serious_Errors_Detected
= 0 then
674 Push_Scope
(Standard_Standard
);
677 while J
<= Inlined_Bodies
.Last
678 and then Serious_Errors_Detected
= 0
680 Pack
:= Inlined_Bodies
.Table
(J
);
682 and then Scope
(Pack
) /= Standard_Standard
683 and then not Is_Child_Unit
(Pack
)
685 Pack
:= Scope
(Pack
);
688 Comp_Unit
:= Parent
(Pack
);
689 while Present
(Comp_Unit
)
690 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
692 Comp_Unit
:= Parent
(Comp_Unit
);
695 -- Load the body if it exists and contains inlineable entities,
696 -- unless it is the main unit, or is an instance whose body has
697 -- already been analyzed.
699 if Present
(Comp_Unit
)
700 and then Comp_Unit
/= Cunit
(Main_Unit
)
701 and then Body_Required
(Comp_Unit
)
703 (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
705 (No
(Corresponding_Body
(Unit
(Comp_Unit
)))
706 and then Body_Needed_For_Inlining
707 (Defining_Entity
(Unit
(Comp_Unit
)))))
710 Bname
: constant Unit_Name_Type
:=
711 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
716 if not Is_Loaded
(Bname
) then
717 Style_Check
:= False;
718 Load_Needed_Body
(Comp_Unit
, OK
);
722 -- Warn that a body was not available for inlining
725 Error_Msg_Unit_1
:= Bname
;
727 ("one or more inlined subprograms accessed in $!??",
730 Get_File_Name
(Bname
, Subunit
=> False);
731 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
739 if J
> Inlined_Bodies
.Last
then
741 -- The analysis of required bodies may have produced additional
742 -- generic instantiations. To obtain further inlining, we need
743 -- to perform another round of generic body instantiations.
747 -- Symmetrically, the instantiation of required generic bodies
748 -- may have caused additional bodies to be inlined. To obtain
749 -- further inlining, we keep looping over the inlined bodies.
753 -- The list of inlined subprograms is an overestimate, because it
754 -- includes inlined functions called from functions that are compiled
755 -- as part of an inlined package, but are not themselves called. An
756 -- accurate computation of just those subprograms that are needed
757 -- requires that we perform a transitive closure over the call graph,
758 -- starting from calls in the main compilation unit.
760 for Index
in Inlined
.First
.. Inlined
.Last
loop
761 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
763 -- This means that Add_Inlined_Body added the subprogram to the
764 -- table but wasn't able to handle its code unit. Do nothing.
766 Inlined
.Table
(Index
).Processed
:= True;
768 elsif Inlined
.Table
(Index
).Main_Call
then
769 Pending_Inlined
.Increment_Last
;
770 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
771 Inlined
.Table
(Index
).Processed
:= True;
774 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
778 -- Iterate over the workpile until it is emptied, propagating the
779 -- Is_Called flag to the successors of the processed subprogram.
781 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
782 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
783 Pending_Inlined
.Decrement_Last
;
785 S
:= Inlined
.Table
(Subp
).First_Succ
;
787 while S
/= No_Succ
loop
788 Subp
:= Successors
.Table
(S
).Subp
;
790 if not Inlined
.Table
(Subp
).Processed
then
791 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
792 Pending_Inlined
.Increment_Last
;
793 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
794 Inlined
.Table
(Subp
).Processed
:= True;
797 S
:= Successors
.Table
(S
).Next
;
801 -- Finally add the called subprograms to the list of inlined
802 -- subprograms for the unit.
804 for Index
in Inlined
.First
.. Inlined
.Last
loop
805 if Is_Called
(Inlined
.Table
(Index
).Name
) then
806 Add_Inlined_Subprogram
(Inlined
.Table
(Index
).Name
);
812 end Analyze_Inlined_Bodies
;
814 --------------------------
815 -- Build_Body_To_Inline --
816 --------------------------
818 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
819 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
820 Analysis_Status
: constant Boolean := Full_Analysis
;
821 Original_Body
: Node_Id
;
822 Body_To_Analyze
: Node_Id
;
823 Max_Size
: constant := 10;
825 function Has_Pending_Instantiation
return Boolean;
826 -- If some enclosing body contains instantiations that appear before
827 -- the corresponding generic body, the enclosing body has a freeze node
828 -- so that it can be elaborated after the generic itself. This might
829 -- conflict with subsequent inlinings, so that it is unsafe to try to
830 -- inline in such a case.
832 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
833 -- This function is called only in GNATprove mode, and it returns
834 -- True if the subprogram has no return statement or a single return
835 -- statement as last statement. It returns False for subprogram with
836 -- a single return as last statement inside one or more blocks, as
837 -- inlining would generate gotos in that case as well (although the
838 -- goto is useless in that case).
840 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
841 -- If the body of the subprogram includes a call that returns an
842 -- unconstrained type, the secondary stack is involved, and it
843 -- is not worth inlining.
845 -------------------------------
846 -- Has_Pending_Instantiation --
847 -------------------------------
849 function Has_Pending_Instantiation
return Boolean is
854 while Present
(S
) loop
855 if Is_Compilation_Unit
(S
)
856 or else Is_Child_Unit
(S
)
860 elsif Ekind
(S
) = E_Package
861 and then Has_Forward_Instantiation
(S
)
870 end Has_Pending_Instantiation
;
872 -----------------------------------------
873 -- Has_Single_Return_In_GNATprove_Mode --
874 -----------------------------------------
876 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
877 Body_To_Inline
: constant Node_Id
:= N
;
878 Last_Statement
: Node_Id
:= Empty
;
880 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
881 -- Returns OK on node N if this is not a return statement different
882 -- from the last statement in the subprogram.
888 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
891 when N_Extended_Return_Statement
892 | N_Simple_Return_Statement
894 if N
= Last_Statement
then
900 -- Skip locally declared subprogram bodies inside the body to
901 -- inline, as the return statements inside those do not count.
903 when N_Subprogram_Body
=>
904 if N
= Body_To_Inline
then
915 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
917 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
920 -- Retrieve the last statement
922 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
924 -- Check that the last statement is the only possible return
925 -- statement in the subprogram.
927 return Check_All_Returns
(N
) = OK
;
928 end Has_Single_Return_In_GNATprove_Mode
;
930 --------------------------
931 -- Uses_Secondary_Stack --
932 --------------------------
934 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
935 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
936 -- Look for function calls that return an unconstrained type
942 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
944 if Nkind
(N
) = N_Function_Call
945 and then Is_Entity_Name
(Name
(N
))
946 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
947 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
950 ("cannot inline & (call returns unconstrained type)?",
958 function Check_Calls
is new Traverse_Func
(Check_Call
);
961 return Check_Calls
(Bod
) = Abandon
;
962 end Uses_Secondary_Stack
;
964 -- Start of processing for Build_Body_To_Inline
967 -- Return immediately if done already
969 if Nkind
(Decl
) = N_Subprogram_Declaration
970 and then Present
(Body_To_Inline
(Decl
))
974 -- Subprograms that have return statements in the middle of the body are
975 -- inlined with gotos. GNATprove does not currently support gotos, so
976 -- we prevent such inlining.
979 and then not Has_Single_Return_In_GNATprove_Mode
981 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
984 -- Functions that return unconstrained composite types require
985 -- secondary stack handling, and cannot currently be inlined, unless
986 -- all return statements return a local variable that is the first
987 -- local declaration in the body.
989 elsif Ekind
(Spec_Id
) = E_Function
990 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
991 and then not Is_Access_Type
(Etype
(Spec_Id
))
992 and then not Is_Constrained
(Etype
(Spec_Id
))
994 if not Has_Single_Return
(N
) then
996 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1000 -- Ditto for functions that return controlled types, where controlled
1001 -- actions interfere in complex ways with inlining.
1003 elsif Ekind
(Spec_Id
) = E_Function
1004 and then Needs_Finalization
(Etype
(Spec_Id
))
1007 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1011 if Present
(Declarations
(N
))
1012 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1017 if Present
(Handled_Statement_Sequence
(N
)) then
1018 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1020 ("cannot inline& (exception handler)?",
1021 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1025 elsif Has_Excluded_Statement
1026 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1032 -- We do not inline a subprogram that is too large, unless it is marked
1033 -- Inline_Always or we are in GNATprove mode. This pragma does not
1034 -- suppress the other checks on inlining (forbidden declarations,
1037 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1038 and then List_Length
1039 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1041 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1045 if Has_Pending_Instantiation
then
1047 ("cannot inline& (forward instance within enclosing body)?",
1052 -- Within an instance, the body to inline must be treated as a nested
1053 -- generic, so that the proper global references are preserved.
1055 -- Note that we do not do this at the library level, because it is not
1056 -- needed, and furthermore this causes trouble if front end inlining
1057 -- is activated (-gnatN).
1059 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1060 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1061 Original_Body
:= Copy_Generic_Node
(N
, Empty
, True);
1063 Original_Body
:= Copy_Separate_Tree
(N
);
1066 -- We need to capture references to the formals in order to substitute
1067 -- the actuals at the point of inlining, i.e. instantiation. To treat
1068 -- the formals as globals to the body to inline, we nest it within a
1069 -- dummy parameterless subprogram, declared within the real one. To
1070 -- avoid generating an internal name (which is never public, and which
1071 -- affects serial numbers of other generated names), we use an internal
1072 -- symbol that cannot conflict with user declarations.
1074 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1075 Set_Defining_Unit_Name
1076 (Specification
(Original_Body
),
1077 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1078 Set_Corresponding_Spec
(Original_Body
, Empty
);
1080 -- Remove all aspects/pragmas that have no meaning in an inlined body
1082 Remove_Aspects_And_Pragmas
(Original_Body
);
1084 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1086 -- Set return type of function, which is also global and does not need
1089 if Ekind
(Spec_Id
) = E_Function
then
1090 Set_Result_Definition
1091 (Specification
(Body_To_Analyze
),
1092 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1095 if No
(Declarations
(N
)) then
1096 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1098 Append
(Body_To_Analyze
, Declarations
(N
));
1101 -- The body to inline is pre-analyzed. In GNATprove mode we must disable
1102 -- full analysis as well so that light expansion does not take place
1103 -- either, and name resolution is unaffected.
1105 Expander_Mode_Save_And_Set
(False);
1106 Full_Analysis
:= False;
1108 Analyze
(Body_To_Analyze
);
1109 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1110 Save_Global_References
(Original_Body
);
1112 Remove
(Body_To_Analyze
);
1114 Expander_Mode_Restore
;
1115 Full_Analysis
:= Analysis_Status
;
1117 -- Restore environment if previously saved
1119 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1123 -- If secondary stack is used, there is no point in inlining. We have
1124 -- already issued the warning in this case, so nothing to do.
1126 if Uses_Secondary_Stack
(Body_To_Analyze
) then
1130 Set_Body_To_Inline
(Decl
, Original_Body
);
1131 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1132 Set_Is_Inlined
(Spec_Id
);
1133 end Build_Body_To_Inline
;
1135 -------------------------------------------
1136 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1137 -------------------------------------------
1139 function Call_Can_Be_Inlined_In_GNATprove_Mode
1141 Subp
: Entity_Id
) return Boolean
1147 F
:= First_Formal
(Subp
);
1148 A
:= First_Actual
(N
);
1149 while Present
(F
) loop
1150 if Ekind
(F
) /= E_Out_Parameter
1151 and then not Same_Type
(Etype
(F
), Etype
(A
))
1153 (Is_By_Reference_Type
(Etype
(A
))
1154 or else Is_Limited_Type
(Etype
(A
)))
1164 end Call_Can_Be_Inlined_In_GNATprove_Mode
;
1166 --------------------------------------
1167 -- Can_Be_Inlined_In_GNATprove_Mode --
1168 --------------------------------------
1170 function Can_Be_Inlined_In_GNATprove_Mode
1171 (Spec_Id
: Entity_Id
;
1172 Body_Id
: Entity_Id
) return Boolean
1174 function Has_Formal_With_Discriminant_Dependent_Fields
1175 (Id
: Entity_Id
) return Boolean;
1176 -- Returns true if the subprogram has at least one formal parameter of
1177 -- an unconstrained record type with per-object constraints on component
1180 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1181 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1184 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1185 -- Returns True if subprogram Id defines a compilation unit
1186 -- Shouldn't this be in Sem_Aux???
1188 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean;
1189 -- Returns True if subprogram Id is defined in the visible part of a
1190 -- package specification.
1192 ---------------------------------------------------
1193 -- Has_Formal_With_Discriminant_Dependent_Fields --
1194 ---------------------------------------------------
1196 function Has_Formal_With_Discriminant_Dependent_Fields
1197 (Id
: Entity_Id
) return Boolean is
1199 function Has_Discriminant_Dependent_Component
1200 (Typ
: Entity_Id
) return Boolean;
1201 -- Determine whether unconstrained record type Typ has at least
1202 -- one component that depends on a discriminant.
1204 ------------------------------------------
1205 -- Has_Discriminant_Dependent_Component --
1206 ------------------------------------------
1208 function Has_Discriminant_Dependent_Component
1209 (Typ
: Entity_Id
) return Boolean
1214 -- Inspect all components of the record type looking for one
1215 -- that depends on a discriminant.
1217 Comp
:= First_Component
(Typ
);
1218 while Present
(Comp
) loop
1219 if Has_Discriminant_Dependent_Constraint
(Comp
) then
1223 Next_Component
(Comp
);
1227 end Has_Discriminant_Dependent_Component
;
1231 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Id
);
1233 Formal_Typ
: Entity_Id
;
1235 -- Start of processing for
1236 -- Has_Formal_With_Discriminant_Dependent_Fields
1239 -- Inspect all parameters of the subprogram looking for a formal
1240 -- of an unconstrained record type with at least one discriminant
1241 -- dependent component.
1243 Formal
:= First_Formal
(Subp_Id
);
1244 while Present
(Formal
) loop
1245 Formal_Typ
:= Etype
(Formal
);
1247 if Is_Record_Type
(Formal_Typ
)
1248 and then not Is_Constrained
(Formal_Typ
)
1249 and then Has_Discriminant_Dependent_Component
(Formal_Typ
)
1254 Next_Formal
(Formal
);
1258 end Has_Formal_With_Discriminant_Dependent_Fields
;
1260 -----------------------
1261 -- Has_Some_Contract --
1262 -----------------------
1264 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean is
1268 -- A call to an expression function may precede the actual body which
1269 -- is inserted at the end of the enclosing declarations. Ensure that
1270 -- the related entity is decorated before inspecting the contract.
1272 if Is_Subprogram_Or_Generic_Subprogram
(Id
) then
1273 Items
:= Contract
(Id
);
1275 return Present
(Items
)
1276 and then (Present
(Pre_Post_Conditions
(Items
)) or else
1277 Present
(Contract_Test_Cases
(Items
)) or else
1278 Present
(Classifications
(Items
)));
1282 end Has_Some_Contract
;
1284 -----------------------------
1285 -- In_Package_Visible_Spec --
1286 -----------------------------
1288 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean is
1289 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1293 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1294 Decl
:= Parent
(Decl
);
1299 return Nkind
(P
) = N_Package_Specification
1300 and then List_Containing
(Decl
) = Visible_Declarations
(P
);
1301 end In_Package_Visible_Spec
;
1303 ------------------------
1304 -- Is_Unit_Subprogram --
1305 ------------------------
1307 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean is
1308 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1310 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1311 Decl
:= Parent
(Decl
);
1314 return Nkind
(Parent
(Decl
)) = N_Compilation_Unit
;
1315 end Is_Unit_Subprogram
;
1317 -- Local declarations
1320 -- Procedure or function entity for the subprogram
1322 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1325 pragma Assert
(Present
(Spec_Id
) or else Present
(Body_Id
));
1327 if Present
(Spec_Id
) then
1333 -- Only local subprograms without contracts are inlined in GNATprove
1334 -- mode, as these are the subprograms which a user is not interested in
1335 -- analyzing in isolation, but rather in the context of their call. This
1336 -- is a convenient convention, that could be changed for an explicit
1337 -- pragma/aspect one day.
1339 -- In a number of special cases, inlining is not desirable or not
1340 -- possible, see below.
1342 -- Do not inline unit-level subprograms
1344 if Is_Unit_Subprogram
(Id
) then
1347 -- Do not inline subprograms declared in the visible part of a package
1349 elsif In_Package_Visible_Spec
(Id
) then
1352 -- Do not inline subprograms marked No_Return, possibly used for
1353 -- signaling errors, which GNATprove handles specially.
1355 elsif No_Return
(Id
) then
1358 -- Do not inline subprograms that have a contract on the spec or the
1359 -- body. Use the contract(s) instead in GNATprove.
1361 elsif (Present
(Spec_Id
) and then Has_Some_Contract
(Spec_Id
))
1363 (Present
(Body_Id
) and then Has_Some_Contract
(Body_Id
))
1367 -- Do not inline expression functions, which are directly inlined at the
1370 elsif (Present
(Spec_Id
) and then Is_Expression_Function
(Spec_Id
))
1372 (Present
(Body_Id
) and then Is_Expression_Function
(Body_Id
))
1376 -- Do not inline generic subprogram instances. The visibility rules of
1377 -- generic instances plays badly with inlining.
1379 elsif Is_Generic_Instance
(Spec_Id
) then
1382 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1383 -- the subprogram body, a similar check is performed after the body
1384 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1386 elsif Present
(Spec_Id
)
1388 (No
(SPARK_Pragma
(Spec_Id
))
1390 Get_SPARK_Mode_From_Annotation
(SPARK_Pragma
(Spec_Id
)) /= On
)
1394 -- Subprograms in generic instances are currently not inlined, to avoid
1395 -- problems with inlining of standard library subprograms.
1397 elsif Instantiation_Location
(Sloc
(Id
)) /= No_Location
then
1400 -- Do not inline predicate functions (treated specially by GNATprove)
1402 elsif Is_Predicate_Function
(Id
) then
1405 -- Do not inline subprograms with a parameter of an unconstrained
1406 -- record type if it has discrimiant dependent fields. Indeed, with
1407 -- such parameters, the frontend cannot always ensure type compliance
1408 -- in record component accesses (in particular with records containing
1411 elsif Has_Formal_With_Discriminant_Dependent_Fields
(Id
) then
1414 -- Otherwise, this is a subprogram declared inside the private part of a
1415 -- package, or inside a package body, or locally in a subprogram, and it
1416 -- does not have any contract. Inline it.
1421 end Can_Be_Inlined_In_GNATprove_Mode
;
1427 procedure Cannot_Inline
1431 Is_Serious
: Boolean := False)
1434 -- In GNATprove mode, inlining is the technical means by which the
1435 -- higher-level goal of contextual analysis is reached, so issue
1436 -- messages about failure to apply contextual analysis to a
1437 -- subprogram, rather than failure to inline it.
1440 and then Msg
(Msg
'First .. Msg
'First + 12) = "cannot inline"
1443 Len1
: constant Positive :=
1444 String (String'("cannot inline"))'Length;
1445 Len2 : constant Positive :=
1446 String (String'("info: no contextual analysis of"))'Length;
1448 New_Msg
: String (1 .. Msg
'Length + Len2
- Len1
);
1451 New_Msg
(1 .. Len2
) := "info: no contextual analysis of";
1452 New_Msg
(Len2
+ 1 .. Msg
'Length + Len2
- Len1
) :=
1453 Msg
(Msg
'First + Len1
.. Msg
'Last);
1454 Cannot_Inline
(New_Msg
, N
, Subp
, Is_Serious
);
1459 pragma Assert
(Msg
(Msg
'Last) = '?');
1461 -- Legacy front end inlining model
1463 if not Back_End_Inlining
then
1465 -- Do not emit warning if this is a predefined unit which is not
1466 -- the main unit. With validity checks enabled, some predefined
1467 -- subprograms may contain nested subprograms and become ineligible
1470 if Is_Predefined_Unit
(Get_Source_Unit
(Subp
))
1471 and then not In_Extended_Main_Source_Unit
(Subp
)
1475 -- In GNATprove mode, issue a warning, and indicate that the
1476 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1479 elsif GNATprove_Mode
then
1480 Set_Is_Inlined_Always
(Subp
, False);
1481 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1483 elsif Has_Pragma_Inline_Always
(Subp
) then
1485 -- Remove last character (question mark) to make this into an
1486 -- error, because the Inline_Always pragma cannot be obeyed.
1488 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1490 elsif Ineffective_Inline_Warnings
then
1491 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1494 -- New semantics relying on back end inlining
1496 elsif Is_Serious
then
1498 -- Remove last character (question mark) to make this into an error.
1500 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1502 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1503 -- is not always inlined by setting flag Is_Inlined_Always to False.
1505 elsif GNATprove_Mode
then
1506 Set_Is_Inlined_Always
(Subp
, False);
1507 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1511 -- Do not emit warning if this is a predefined unit which is not
1512 -- the main unit. This behavior is currently provided for backward
1513 -- compatibility but it will be removed when we enforce the
1514 -- strictness of the new rules.
1516 if Is_Predefined_Unit
(Get_Source_Unit
(Subp
))
1517 and then not In_Extended_Main_Source_Unit
(Subp
)
1521 elsif Has_Pragma_Inline_Always
(Subp
) then
1523 -- Emit a warning if this is a call to a runtime subprogram
1524 -- which is located inside a generic. Previously this call
1525 -- was silently skipped.
1527 if Is_Generic_Instance
(Subp
) then
1529 Gen_P
: constant Entity_Id
:= Generic_Parent
(Parent
(Subp
));
1531 if Is_Predefined_Unit
(Get_Source_Unit
(Gen_P
)) then
1532 Set_Is_Inlined
(Subp
, False);
1533 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1539 -- Remove last character (question mark) to make this into an
1540 -- error, because the Inline_Always pragma cannot be obeyed.
1542 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1545 Set_Is_Inlined
(Subp
, False);
1547 if Ineffective_Inline_Warnings
then
1548 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1554 --------------------------------------------
1555 -- Check_And_Split_Unconstrained_Function --
1556 --------------------------------------------
1558 procedure Check_And_Split_Unconstrained_Function
1560 Spec_Id
: Entity_Id
;
1561 Body_Id
: Entity_Id
)
1563 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
);
1564 -- Use generic machinery to build an unexpanded body for the subprogram.
1565 -- This body is subsequently used for inline expansions at call sites.
1567 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean;
1568 -- Return true if we generate code for the function body N, the function
1569 -- body N has no local declarations and its unique statement is a single
1570 -- extended return statement with a handled statements sequence.
1572 procedure Generate_Subprogram_Body
1574 Body_To_Inline
: out Node_Id
);
1575 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1576 -- of pragmas referencing the formals are removed since they have no
1577 -- meaning when the body is inlined and the formals are rewritten (the
1578 -- analysis of the non-inlined body will handle these pragmas properly).
1579 -- A new internal name is associated with Body_To_Inline.
1581 procedure Split_Unconstrained_Function
1583 Spec_Id
: Entity_Id
);
1584 -- N is an inlined function body that returns an unconstrained type and
1585 -- has a single extended return statement. Split N in two subprograms:
1586 -- a procedure P' and a function F'. The formals of P' duplicate the
1587 -- formals of N plus an extra formal which is used return a value;
1588 -- its body is composed by the declarations and list of statements
1589 -- of the extended return statement of N.
1591 --------------------------
1592 -- Build_Body_To_Inline --
1593 --------------------------
1595 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1596 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1597 Original_Body
: Node_Id
;
1598 Body_To_Analyze
: Node_Id
;
1601 pragma Assert
(Current_Scope
= Spec_Id
);
1603 -- Within an instance, the body to inline must be treated as a nested
1604 -- generic, so that the proper global references are preserved. We
1605 -- do not do this at the library level, because it is not needed, and
1606 -- furthermore this causes trouble if front end inlining is activated
1610 and then Scope
(Current_Scope
) /= Standard_Standard
1612 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1615 -- We need to capture references to the formals in order
1616 -- to substitute the actuals at the point of inlining, i.e.
1617 -- instantiation. To treat the formals as globals to the body to
1618 -- inline, we nest it within a dummy parameterless subprogram,
1619 -- declared within the real one.
1621 Generate_Subprogram_Body
(N
, Original_Body
);
1622 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1624 -- Set return type of function, which is also global and does not
1625 -- need to be resolved.
1627 if Ekind
(Spec_Id
) = E_Function
then
1628 Set_Result_Definition
(Specification
(Body_To_Analyze
),
1629 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1632 if No
(Declarations
(N
)) then
1633 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1635 Append_To
(Declarations
(N
), Body_To_Analyze
);
1638 Preanalyze
(Body_To_Analyze
);
1640 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1641 Save_Global_References
(Original_Body
);
1643 Remove
(Body_To_Analyze
);
1645 -- Restore environment if previously saved
1648 and then Scope
(Current_Scope
) /= Standard_Standard
1653 pragma Assert
(No
(Body_To_Inline
(Decl
)));
1654 Set_Body_To_Inline
(Decl
, Original_Body
);
1655 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1656 end Build_Body_To_Inline
;
1658 --------------------------------------
1659 -- Can_Split_Unconstrained_Function --
1660 --------------------------------------
1662 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean
1664 Ret_Node
: constant Node_Id
:=
1665 First
(Statements
(Handled_Statement_Sequence
(N
)));
1669 -- No user defined declarations allowed in the function except inside
1670 -- the unique return statement; implicit labels are the only allowed
1673 if not Is_Empty_List
(Declarations
(N
)) then
1674 D
:= First
(Declarations
(N
));
1675 while Present
(D
) loop
1676 if Nkind
(D
) /= N_Implicit_Label_Declaration
then
1684 -- We only split the inlined function when we are generating the code
1685 -- of its body; otherwise we leave duplicated split subprograms in
1686 -- the tree which (if referenced) generate wrong references at link
1689 return In_Extended_Main_Code_Unit
(N
)
1690 and then Present
(Ret_Node
)
1691 and then Nkind
(Ret_Node
) = N_Extended_Return_Statement
1692 and then No
(Next
(Ret_Node
))
1693 and then Present
(Handled_Statement_Sequence
(Ret_Node
));
1694 end Can_Split_Unconstrained_Function
;
1696 -----------------------------
1697 -- Generate_Body_To_Inline --
1698 -----------------------------
1700 procedure Generate_Subprogram_Body
1702 Body_To_Inline
: out Node_Id
)
1705 -- Within an instance, the body to inline must be treated as a nested
1706 -- generic, so that the proper global references are preserved.
1708 -- Note that we do not do this at the library level, because it
1709 -- is not needed, and furthermore this causes trouble if front
1710 -- end inlining is activated (-gnatN).
1713 and then Scope
(Current_Scope
) /= Standard_Standard
1715 Body_To_Inline
:= Copy_Generic_Node
(N
, Empty
, True);
1717 Body_To_Inline
:= Copy_Separate_Tree
(N
);
1720 -- Remove all aspects/pragmas that have no meaning in an inlined body
1722 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
1724 -- We need to capture references to the formals in order
1725 -- to substitute the actuals at the point of inlining, i.e.
1726 -- instantiation. To treat the formals as globals to the body to
1727 -- inline, we nest it within a dummy parameterless subprogram,
1728 -- declared within the real one.
1730 Set_Parameter_Specifications
1731 (Specification
(Body_To_Inline
), No_List
);
1733 -- A new internal name is associated with Body_To_Inline to avoid
1734 -- conflicts when the non-inlined body N is analyzed.
1736 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
1737 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
1738 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
1739 end Generate_Subprogram_Body
;
1741 ----------------------------------
1742 -- Split_Unconstrained_Function --
1743 ----------------------------------
1745 procedure Split_Unconstrained_Function
1747 Spec_Id
: Entity_Id
)
1749 Loc
: constant Source_Ptr
:= Sloc
(N
);
1750 Ret_Node
: constant Node_Id
:=
1751 First
(Statements
(Handled_Statement_Sequence
(N
)));
1752 Ret_Obj
: constant Node_Id
:=
1753 First
(Return_Object_Declarations
(Ret_Node
));
1755 procedure Build_Procedure
1756 (Proc_Id
: out Entity_Id
;
1757 Decl_List
: out List_Id
);
1758 -- Build a procedure containing the statements found in the extended
1759 -- return statement of the unconstrained function body N.
1761 ---------------------
1762 -- Build_Procedure --
1763 ---------------------
1765 procedure Build_Procedure
1766 (Proc_Id
: out Entity_Id
;
1767 Decl_List
: out List_Id
)
1770 Formal_List
: constant List_Id
:= New_List
;
1771 Proc_Spec
: Node_Id
;
1772 Proc_Body
: Node_Id
;
1773 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
1774 Body_Decl_List
: List_Id
:= No_List
;
1775 Param_Type
: Node_Id
;
1778 if Nkind
(Object_Definition
(Ret_Obj
)) = N_Identifier
then
1780 New_Copy
(Object_Definition
(Ret_Obj
));
1783 New_Copy
(Subtype_Mark
(Object_Definition
(Ret_Obj
)));
1786 Append_To
(Formal_List
,
1787 Make_Parameter_Specification
(Loc
,
1788 Defining_Identifier
=>
1789 Make_Defining_Identifier
(Loc
,
1790 Chars
=> Chars
(Defining_Identifier
(Ret_Obj
))),
1791 In_Present
=> False,
1792 Out_Present
=> True,
1793 Null_Exclusion_Present
=> False,
1794 Parameter_Type
=> Param_Type
));
1796 Formal
:= First_Formal
(Spec_Id
);
1798 -- Note that we copy the parameter type rather than creating
1799 -- a reference to it, because it may be a class-wide entity
1800 -- that will not be retrieved by name.
1802 while Present
(Formal
) loop
1803 Append_To
(Formal_List
,
1804 Make_Parameter_Specification
(Loc
,
1805 Defining_Identifier
=>
1806 Make_Defining_Identifier
(Sloc
(Formal
),
1807 Chars
=> Chars
(Formal
)),
1808 In_Present
=> In_Present
(Parent
(Formal
)),
1809 Out_Present
=> Out_Present
(Parent
(Formal
)),
1810 Null_Exclusion_Present
=>
1811 Null_Exclusion_Present
(Parent
(Formal
)),
1813 New_Copy_Tree
(Parameter_Type
(Parent
(Formal
))),
1815 Copy_Separate_Tree
(Expression
(Parent
(Formal
)))));
1817 Next_Formal
(Formal
);
1820 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
1823 Make_Procedure_Specification
(Loc
,
1824 Defining_Unit_Name
=> Proc_Id
,
1825 Parameter_Specifications
=> Formal_List
);
1827 Decl_List
:= New_List
;
1829 Append_To
(Decl_List
,
1830 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
1832 -- Can_Convert_Unconstrained_Function checked that the function
1833 -- has no local declarations except implicit label declarations.
1834 -- Copy these declarations to the built procedure.
1836 if Present
(Declarations
(N
)) then
1837 Body_Decl_List
:= New_List
;
1844 D
:= First
(Declarations
(N
));
1845 while Present
(D
) loop
1846 pragma Assert
(Nkind
(D
) = N_Implicit_Label_Declaration
);
1849 Make_Implicit_Label_Declaration
(Loc
,
1850 Make_Defining_Identifier
(Loc
,
1851 Chars
=> Chars
(Defining_Identifier
(D
))),
1852 Label_Construct
=> Empty
);
1853 Append_To
(Body_Decl_List
, New_D
);
1860 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Node
)));
1863 Make_Subprogram_Body
(Loc
,
1864 Specification
=> Copy_Separate_Tree
(Proc_Spec
),
1865 Declarations
=> Body_Decl_List
,
1866 Handled_Statement_Sequence
=>
1867 Copy_Separate_Tree
(Handled_Statement_Sequence
(Ret_Node
)));
1869 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
1870 Make_Defining_Identifier
(Loc
, Subp_Name
));
1872 Append_To
(Decl_List
, Proc_Body
);
1873 end Build_Procedure
;
1877 New_Obj
: constant Node_Id
:= Copy_Separate_Tree
(Ret_Obj
);
1879 Proc_Id
: Entity_Id
;
1880 Proc_Call
: Node_Id
;
1882 -- Start of processing for Split_Unconstrained_Function
1885 -- Build the associated procedure, analyze it and insert it before
1886 -- the function body N.
1889 Scope
: constant Entity_Id
:= Current_Scope
;
1890 Decl_List
: List_Id
;
1893 Build_Procedure
(Proc_Id
, Decl_List
);
1894 Insert_Actions
(N
, Decl_List
);
1898 -- Build the call to the generated procedure
1901 Actual_List
: constant List_Id
:= New_List
;
1905 Append_To
(Actual_List
,
1906 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
1908 Formal
:= First_Formal
(Spec_Id
);
1909 while Present
(Formal
) loop
1910 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
1912 -- Avoid spurious warning on unreferenced formals
1914 Set_Referenced
(Formal
);
1915 Next_Formal
(Formal
);
1919 Make_Procedure_Call_Statement
(Loc
,
1920 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
1921 Parameter_Associations
=> Actual_List
);
1929 -- main_1__F1b (New_Obj, ...);
1934 Make_Block_Statement
(Loc
,
1935 Declarations
=> New_List
(New_Obj
),
1936 Handled_Statement_Sequence
=>
1937 Make_Handled_Sequence_Of_Statements
(Loc
,
1938 Statements
=> New_List
(
1942 Make_Simple_Return_Statement
(Loc
,
1945 (Defining_Identifier
(New_Obj
), Loc
)))));
1947 Rewrite
(Ret_Node
, Blk_Stmt
);
1948 end Split_Unconstrained_Function
;
1952 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1954 -- Start of processing for Check_And_Split_Unconstrained_Function
1957 pragma Assert
(Back_End_Inlining
1958 and then Ekind
(Spec_Id
) = E_Function
1959 and then Returns_Unconstrained_Type
(Spec_Id
)
1960 and then Comes_From_Source
(Body_Id
)
1961 and then (Has_Pragma_Inline_Always
(Spec_Id
)
1962 or else Optimization_Level
> 0));
1964 -- This routine must not be used in GNATprove mode since GNATprove
1965 -- relies on frontend inlining
1967 pragma Assert
(not GNATprove_Mode
);
1969 -- No need to split the function if we cannot generate the code
1971 if Serious_Errors_Detected
/= 0 then
1975 -- No action needed in stubs since the attribute Body_To_Inline
1978 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
1981 -- Cannot build the body to inline if the attribute is already set.
1982 -- This attribute may have been set if this is a subprogram renaming
1983 -- declarations (see Freeze.Build_Renamed_Body).
1985 elsif Present
(Body_To_Inline
(Decl
)) then
1988 -- Check excluded declarations
1990 elsif Present
(Declarations
(N
))
1991 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1995 -- Check excluded statements. There is no need to protect us against
1996 -- exception handlers since they are supported by the GCC backend.
1998 elsif Present
(Handled_Statement_Sequence
(N
))
1999 and then Has_Excluded_Statement
2000 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2005 -- Build the body to inline only if really needed
2007 if Can_Split_Unconstrained_Function
(N
) then
2008 Split_Unconstrained_Function
(N
, Spec_Id
);
2009 Build_Body_To_Inline
(N
, Spec_Id
);
2010 Set_Is_Inlined
(Spec_Id
);
2012 end Check_And_Split_Unconstrained_Function
;
2014 -------------------------------------
2015 -- Check_Package_Body_For_Inlining --
2016 -------------------------------------
2018 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2019 Bname
: Unit_Name_Type
;
2024 -- Legacy implementation (relying on frontend inlining)
2026 if not Back_End_Inlining
2027 and then Is_Compilation_Unit
(P
)
2028 and then not Is_Generic_Instance
(P
)
2030 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2032 E
:= First_Entity
(P
);
2033 while Present
(E
) loop
2034 if Has_Pragma_Inline_Always
(E
)
2035 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2037 if not Is_Loaded
(Bname
) then
2038 Load_Needed_Body
(N
, OK
);
2042 -- Check we are not trying to inline a parent whose body
2043 -- depends on a child, when we are compiling the body of
2044 -- the child. Otherwise we have a potential elaboration
2045 -- circularity with inlined subprograms and with
2046 -- Taft-Amendment types.
2049 Comp
: Node_Id
; -- Body just compiled
2050 Child_Spec
: Entity_Id
; -- Spec of main unit
2051 Ent
: Entity_Id
; -- For iteration
2052 With_Clause
: Node_Id
; -- Context of body.
2055 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2056 and then Present
(Body_Entity
(P
))
2060 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2063 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2065 -- Check whether the context of the body just
2066 -- compiled includes a child of itself, and that
2067 -- child is the spec of the main compilation.
2069 With_Clause
:= First
(Context_Items
(Comp
));
2070 while Present
(With_Clause
) loop
2071 if Nkind
(With_Clause
) = N_With_Clause
2073 Scope
(Entity
(Name
(With_Clause
))) = P
2075 Entity
(Name
(With_Clause
)) = Child_Spec
2077 Error_Msg_Node_2
:= Child_Spec
;
2079 ("body of & depends on child unit&??",
2082 ("\subprograms in body cannot be inlined??",
2085 -- Disable further inlining from this unit,
2086 -- and keep Taft-amendment types incomplete.
2088 Ent
:= First_Entity
(P
);
2089 while Present
(Ent
) loop
2091 and then Has_Completion_In_Body
(Ent
)
2093 Set_Full_View
(Ent
, Empty
);
2095 elsif Is_Subprogram
(Ent
) then
2096 Set_Is_Inlined
(Ent
, False);
2110 elsif Ineffective_Inline_Warnings
then
2111 Error_Msg_Unit_1
:= Bname
;
2113 ("unable to inline subprograms defined in $??", P
);
2114 Error_Msg_N
("\body not found??", P
);
2125 end Check_Package_Body_For_Inlining
;
2127 --------------------
2128 -- Cleanup_Scopes --
2129 --------------------
2131 procedure Cleanup_Scopes
is
2137 Elmt
:= First_Elmt
(To_Clean
);
2138 while Present
(Elmt
) loop
2139 Scop
:= Node
(Elmt
);
2141 if Ekind
(Scop
) = E_Entry
then
2142 Scop
:= Protected_Body_Subprogram
(Scop
);
2144 elsif Is_Subprogram
(Scop
)
2145 and then Is_Protected_Type
(Scope
(Scop
))
2146 and then Present
(Protected_Body_Subprogram
(Scop
))
2148 -- If a protected operation contains an instance, its cleanup
2149 -- operations have been delayed, and the subprogram has been
2150 -- rewritten in the expansion of the enclosing protected body. It
2151 -- is the corresponding subprogram that may require the cleanup
2152 -- operations, so propagate the information that triggers cleanup
2156 (Protected_Body_Subprogram
(Scop
),
2157 Uses_Sec_Stack
(Scop
));
2159 Scop
:= Protected_Body_Subprogram
(Scop
);
2162 if Ekind
(Scop
) = E_Block
then
2163 Decl
:= Parent
(Block_Node
(Scop
));
2166 Decl
:= Unit_Declaration_Node
(Scop
);
2168 if Nkind_In
(Decl
, N_Subprogram_Declaration
,
2169 N_Task_Type_Declaration
,
2170 N_Subprogram_Body_Stub
)
2172 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2177 Expand_Cleanup_Actions
(Decl
);
2180 Elmt
:= Next_Elmt
(Elmt
);
2184 -------------------------
2185 -- Expand_Inlined_Call --
2186 -------------------------
2188 procedure Expand_Inlined_Call
2191 Orig_Subp
: Entity_Id
)
2193 Loc
: constant Source_Ptr
:= Sloc
(N
);
2194 Is_Predef
: constant Boolean :=
2195 Is_Predefined_Unit
(Get_Source_Unit
(Subp
));
2196 Orig_Bod
: constant Node_Id
:=
2197 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2201 Decls
: constant List_Id
:= New_List
;
2202 Exit_Lab
: Entity_Id
:= Empty
;
2209 Ret_Type
: Entity_Id
;
2212 -- The target of the call. If context is an assignment statement then
2213 -- this is the left-hand side of the assignment, else it is a temporary
2214 -- to which the return value is assigned prior to rewriting the call.
2216 Targ1
: Node_Id
:= Empty
;
2217 -- A separate target used when the return type is unconstrained
2220 Temp_Typ
: Entity_Id
;
2222 Return_Object
: Entity_Id
:= Empty
;
2223 -- Entity in declaration in an extended_return_statement
2226 Is_Unc_Decl
: Boolean;
2227 -- If the type returned by the function is unconstrained and the call
2228 -- can be inlined, special processing is required.
2230 procedure Declare_Postconditions_Result
;
2231 -- When generating C code, declare _Result, which may be used in the
2232 -- inlined _Postconditions procedure to verify the return value.
2234 procedure Make_Exit_Label
;
2235 -- Build declaration for exit label to be used in Return statements,
2236 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2237 -- declaration). Does nothing if Exit_Lab already set.
2239 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2240 -- Replace occurrence of a formal with the corresponding actual, or the
2241 -- thunk generated for it. Replace a return statement with an assignment
2242 -- to the target of the call, with appropriate conversions if needed.
2244 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2245 -- If the call being expanded is that of an internal subprogram, set the
2246 -- sloc of the generated block to that of the call itself, so that the
2247 -- expansion is skipped by the "next" command in gdb. Same processing
2248 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2249 -- Debug_Generated_Code is true, suppress this change to simplify our
2250 -- own development. Same in GNATprove mode, to ensure that warnings and
2251 -- diagnostics point to the proper location.
2253 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
2254 -- In subtree N search for occurrences of dispatching calls that use the
2255 -- Ada 2005 Object.Operation notation and the object is a formal of the
2256 -- inlined subprogram. Reset the entity associated with Operation in all
2257 -- the found occurrences.
2259 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2260 -- If the function body is a single expression, replace call with
2261 -- expression, else insert block appropriately.
2263 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2264 -- If procedure body has no local variables, inline body without
2265 -- creating block, otherwise rewrite call with block.
2267 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2268 -- Determine whether a formal parameter is used only once in Orig_Bod
2270 -----------------------------------
2271 -- Declare_Postconditions_Result --
2272 -----------------------------------
2274 procedure Declare_Postconditions_Result
is
2275 Enclosing_Subp
: constant Entity_Id
:= Scope
(Subp
);
2280 and then Is_Subprogram
(Enclosing_Subp
)
2281 and then Present
(Postconditions_Proc
(Enclosing_Subp
)));
2283 if Ekind
(Enclosing_Subp
) = E_Function
then
2284 if Nkind
(First
(Parameter_Associations
(N
))) in
2285 N_Numeric_Or_String_Literal
2287 Append_To
(Declarations
(Blk
),
2288 Make_Object_Declaration
(Loc
,
2289 Defining_Identifier
=>
2290 Make_Defining_Identifier
(Loc
, Name_uResult
),
2291 Constant_Present
=> True,
2292 Object_Definition
=>
2293 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2295 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2297 Append_To
(Declarations
(Blk
),
2298 Make_Object_Renaming_Declaration
(Loc
,
2299 Defining_Identifier
=>
2300 Make_Defining_Identifier
(Loc
, Name_uResult
),
2302 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2304 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2307 end Declare_Postconditions_Result
;
2309 ---------------------
2310 -- Make_Exit_Label --
2311 ---------------------
2313 procedure Make_Exit_Label
is
2314 Lab_Ent
: Entity_Id
;
2316 if No
(Exit_Lab
) then
2317 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
2318 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
2319 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2321 Make_Implicit_Label_Declaration
(Loc
,
2322 Defining_Identifier
=> Lab_Ent
,
2323 Label_Construct
=> Exit_Lab
);
2325 end Make_Exit_Label
;
2327 ---------------------
2328 -- Process_Formals --
2329 ---------------------
2331 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2337 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
2340 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
2341 A
:= Renamed_Object
(E
);
2343 -- Rewrite the occurrence of the formal into an occurrence of
2344 -- the actual. Also establish visibility on the proper view of
2345 -- the actual's subtype for the body's context (if the actual's
2346 -- subtype is private at the call point but its full view is
2347 -- visible to the body, then the inlined tree here must be
2348 -- analyzed with the full view).
2350 if Is_Entity_Name
(A
) then
2351 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
2352 Check_Private_View
(N
);
2354 elsif Nkind
(A
) = N_Defining_Identifier
then
2355 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
2356 Check_Private_View
(N
);
2361 Rewrite
(N
, New_Copy
(A
));
2367 elsif Is_Entity_Name
(N
)
2368 and then Present
(Return_Object
)
2369 and then Chars
(N
) = Chars
(Return_Object
)
2371 -- Occurrence within an extended return statement. The return
2372 -- object is local to the body been inlined, and thus the generic
2373 -- copy is not analyzed yet, so we match by name, and replace it
2374 -- with target of call.
2376 if Nkind
(Targ
) = N_Defining_Identifier
then
2377 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
2379 Rewrite
(N
, New_Copy_Tree
(Targ
));
2384 elsif Nkind
(N
) = N_Simple_Return_Statement
then
2385 if No
(Expression
(N
)) then
2386 Num_Ret
:= Num_Ret
+ 1;
2389 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2392 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2393 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2395 -- Function body is a single expression. No need for
2401 Num_Ret
:= Num_Ret
+ 1;
2405 -- Because of the presence of private types, the views of the
2406 -- expression and the context may be different, so place an
2407 -- unchecked conversion to the context type to avoid spurious
2408 -- errors, e.g. when the expression is a numeric literal and
2409 -- the context is private. If the expression is an aggregate,
2410 -- use a qualified expression, because an aggregate is not a
2411 -- legal argument of a conversion. Ditto for numeric literals
2412 -- and attributes that yield a universal type, because those
2413 -- must be resolved to a specific type.
2415 if Nkind_In
(Expression
(N
), N_Aggregate
, N_Null
)
2416 or else Yields_Universal_Type
(Expression
(N
))
2419 Make_Qualified_Expression
(Sloc
(N
),
2420 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2421 Expression
=> Relocate_Node
(Expression
(N
)));
2424 Unchecked_Convert_To
2425 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2428 if Nkind
(Targ
) = N_Defining_Identifier
then
2430 Make_Assignment_Statement
(Loc
,
2431 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2432 Expression
=> Ret
));
2435 Make_Assignment_Statement
(Loc
,
2436 Name
=> New_Copy
(Targ
),
2437 Expression
=> Ret
));
2440 Set_Assignment_OK
(Name
(N
));
2442 if Present
(Exit_Lab
) then
2444 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2450 -- An extended return becomes a block whose first statement is the
2451 -- assignment of the initial expression of the return object to the
2452 -- target of the call itself.
2454 elsif Nkind
(N
) = N_Extended_Return_Statement
then
2456 Return_Decl
: constant Entity_Id
:=
2457 First
(Return_Object_Declarations
(N
));
2461 Return_Object
:= Defining_Identifier
(Return_Decl
);
2463 if Present
(Expression
(Return_Decl
)) then
2464 if Nkind
(Targ
) = N_Defining_Identifier
then
2466 Make_Assignment_Statement
(Loc
,
2467 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2468 Expression
=> Expression
(Return_Decl
));
2471 Make_Assignment_Statement
(Loc
,
2472 Name
=> New_Copy
(Targ
),
2473 Expression
=> Expression
(Return_Decl
));
2476 Set_Assignment_OK
(Name
(Assign
));
2478 if No
(Handled_Statement_Sequence
(N
)) then
2479 Set_Handled_Statement_Sequence
(N
,
2480 Make_Handled_Sequence_Of_Statements
(Loc
,
2481 Statements
=> New_List
));
2485 Statements
(Handled_Statement_Sequence
(N
)));
2489 Make_Block_Statement
(Loc
,
2490 Handled_Statement_Sequence
=>
2491 Handled_Statement_Sequence
(N
)));
2496 -- Remove pragma Unreferenced since it may refer to formals that
2497 -- are not visible in the inlined body, and in any case we will
2498 -- not be posting warnings on the inlined body so it is unneeded.
2500 elsif Nkind
(N
) = N_Pragma
2501 and then Pragma_Name
(N
) = Name_Unreferenced
2503 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2509 end Process_Formals
;
2511 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2517 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2519 if not Debug_Generated_Code
then
2520 Set_Sloc
(Nod
, Sloc
(N
));
2521 Set_Comes_From_Source
(Nod
, False);
2527 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2529 ------------------------------
2530 -- Reset_Dispatching_Calls --
2531 ------------------------------
2533 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
2535 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
2536 -- Comment required ???
2542 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
2544 if Nkind
(N
) = N_Procedure_Call_Statement
2545 and then Nkind
(Name
(N
)) = N_Selected_Component
2546 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
2547 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
2548 and then Is_Dispatching_Operation
2549 (Entity
(Selector_Name
(Name
(N
))))
2551 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
2557 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
2561 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
2562 pragma Unreferenced
(Dummy
);
2564 -- Start of processing for Reset_Dispatching_Calls
2568 end Reset_Dispatching_Calls
;
2570 ---------------------------
2571 -- Rewrite_Function_Call --
2572 ---------------------------
2574 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2575 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2576 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2579 -- Optimize simple case: function body is a single return statement,
2580 -- which has been expanded into an assignment.
2582 if Is_Empty_List
(Declarations
(Blk
))
2583 and then Nkind
(Fst
) = N_Assignment_Statement
2584 and then No
(Next
(Fst
))
2586 -- The function call may have been rewritten as the temporary
2587 -- that holds the result of the call, in which case remove the
2588 -- now useless declaration.
2590 if Nkind
(N
) = N_Identifier
2591 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2593 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2596 Rewrite
(N
, Expression
(Fst
));
2598 elsif Nkind
(N
) = N_Identifier
2599 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2601 -- The block assigns the result of the call to the temporary
2603 Insert_After
(Parent
(Entity
(N
)), Blk
);
2605 -- If the context is an assignment, and the left-hand side is free of
2606 -- side-effects, the replacement is also safe.
2607 -- Can this be generalized further???
2609 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2611 (Is_Entity_Name
(Name
(Parent
(N
)))
2613 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
2614 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
2617 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2618 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
2620 -- Replace assignment with the block
2623 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2626 -- Preserve the original assignment node to keep the complete
2627 -- assignment subtree consistent enough for Analyze_Assignment
2628 -- to proceed (specifically, the original Lhs node must still
2629 -- have an assignment statement as its parent).
2631 -- We cannot rely on Original_Node to go back from the block
2632 -- node to the assignment node, because the assignment might
2633 -- already be a rewrite substitution.
2635 Discard_Node
(Relocate_Node
(Original_Assignment
));
2636 Rewrite
(Original_Assignment
, Blk
);
2639 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2641 -- A call to a function which returns an unconstrained type
2642 -- found in the expression initializing an object-declaration is
2643 -- expanded into a procedure call which must be added after the
2644 -- object declaration.
2646 if Is_Unc_Decl
and Back_End_Inlining
then
2647 Insert_Action_After
(Parent
(N
), Blk
);
2649 Set_Expression
(Parent
(N
), Empty
);
2650 Insert_After
(Parent
(N
), Blk
);
2653 elsif Is_Unc
and then not Back_End_Inlining
then
2654 Insert_Before
(Parent
(N
), Blk
);
2656 end Rewrite_Function_Call
;
2658 ----------------------------
2659 -- Rewrite_Procedure_Call --
2660 ----------------------------
2662 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2663 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2666 -- If there is a transient scope for N, this will be the scope of the
2667 -- actions for N, and the statements in Blk need to be within this
2668 -- scope. For example, they need to have visibility on the constant
2669 -- declarations created for the formals.
2671 -- If N needs no transient scope, and if there are no declarations in
2672 -- the inlined body, we can do a little optimization and insert the
2673 -- statements for the body directly after N, and rewrite N to a
2674 -- null statement, instead of rewriting N into a full-blown block
2677 if not Scope_Is_Transient
2678 and then Is_Empty_List
(Declarations
(Blk
))
2680 Insert_List_After
(N
, Statements
(HSS
));
2681 Rewrite
(N
, Make_Null_Statement
(Loc
));
2685 end Rewrite_Procedure_Call
;
2687 -------------------------
2688 -- Formal_Is_Used_Once --
2689 -------------------------
2691 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2692 Use_Counter
: Int
:= 0;
2694 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2695 -- Traverse the tree and count the uses of the formal parameter.
2696 -- In this case, for optimization purposes, we do not need to
2697 -- continue the traversal once more than one use is encountered.
2703 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2705 -- The original node is an identifier
2707 if Nkind
(N
) = N_Identifier
2708 and then Present
(Entity
(N
))
2710 -- Original node's entity points to the one in the copied body
2712 and then Nkind
(Entity
(N
)) = N_Identifier
2713 and then Present
(Entity
(Entity
(N
)))
2715 -- The entity of the copied node is the formal parameter
2717 and then Entity
(Entity
(N
)) = Formal
2719 Use_Counter
:= Use_Counter
+ 1;
2721 if Use_Counter
> 1 then
2723 -- Denote more than one use and abandon the traversal
2734 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2736 -- Start of processing for Formal_Is_Used_Once
2739 Count_Formal_Uses
(Orig_Bod
);
2740 return Use_Counter
= 1;
2741 end Formal_Is_Used_Once
;
2743 -- Start of processing for Expand_Inlined_Call
2746 -- Initializations for old/new semantics
2748 if not Back_End_Inlining
then
2749 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
2750 and then not Is_Constrained
(Etype
(Subp
));
2751 Is_Unc_Decl
:= False;
2753 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
2754 and then Optimization_Level
> 0;
2755 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
2759 -- Check for an illegal attempt to inline a recursive procedure. If the
2760 -- subprogram has parameters this is detected when trying to supply a
2761 -- binding for parameters that already have one. For parameterless
2762 -- subprograms this must be done explicitly.
2764 if In_Open_Scopes
(Subp
) then
2766 ("cannot inline call to recursive subprogram?", N
, Subp
);
2767 Set_Is_Inlined
(Subp
, False);
2770 -- Skip inlining if this is not a true inlining since the attribute
2771 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2772 -- true inlining, Orig_Bod has code rather than being an entity.
2774 elsif Nkind
(Orig_Bod
) in N_Entity
then
2777 -- Skip inlining if the function returns an unconstrained type using
2778 -- an extended return statement since this part of the new inlining
2779 -- model which is not yet supported by the current implementation. ???
2783 Nkind
(First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2784 N_Extended_Return_Statement
2785 and then not Back_End_Inlining
2790 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2791 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2793 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2794 -- can be replaced with calls to the renamed entity directly, because
2795 -- the subprograms are subtype conformant. If the renamed subprogram
2796 -- is an inherited operation, we must redo the expansion because
2797 -- implicit conversions may be needed. Similarly, if the renamed
2798 -- entity is inlined, expand the call for further optimizations.
2800 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2802 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
2809 -- Register the call in the list of inlined calls
2811 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
2813 -- Use generic machinery to copy body of inlined subprogram, as if it
2814 -- were an instantiation, resetting source locations appropriately, so
2815 -- that nested inlined calls appear in the main unit.
2817 Save_Env
(Subp
, Empty
);
2818 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2822 if not Back_End_Inlining
then
2827 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2829 Make_Block_Statement
(Loc
,
2830 Declarations
=> Declarations
(Bod
),
2831 Handled_Statement_Sequence
=>
2832 Handled_Statement_Sequence
(Bod
));
2834 if No
(Declarations
(Bod
)) then
2835 Set_Declarations
(Blk
, New_List
);
2838 -- When generating C code, declare _Result, which may be used to
2839 -- verify the return value.
2841 if Modify_Tree_For_C
2842 and then Nkind
(N
) = N_Procedure_Call_Statement
2843 and then Chars
(Name
(N
)) = Name_uPostconditions
2845 Declare_Postconditions_Result
;
2848 -- For the unconstrained case, capture the name of the local
2849 -- variable that holds the result. This must be the first
2850 -- declaration in the block, because its bounds cannot depend
2851 -- on local variables. Otherwise there is no way to declare the
2852 -- result outside of the block. Needless to say, in general the
2853 -- bounds will depend on the actuals in the call.
2855 -- If the context is an assignment statement, as is the case
2856 -- for the expansion of an extended return, the left-hand side
2857 -- provides bounds even if the return type is unconstrained.
2861 First_Decl
: Node_Id
;
2864 First_Decl
:= First
(Declarations
(Blk
));
2866 if Nkind
(First_Decl
) /= N_Object_Declaration
then
2870 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2871 Targ1
:= Defining_Identifier
(First_Decl
);
2873 Targ1
:= Name
(Parent
(N
));
2890 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2892 Make_Block_Statement
(Loc
,
2893 Declarations
=> Declarations
(Bod
),
2894 Handled_Statement_Sequence
=>
2895 Handled_Statement_Sequence
(Bod
));
2897 -- Inline a call to a function that returns an unconstrained type.
2898 -- The semantic analyzer checked that frontend-inlined functions
2899 -- returning unconstrained types have no declarations and have
2900 -- a single extended return statement. As part of its processing
2901 -- the function was split in two subprograms: a procedure P and
2902 -- a function F that has a block with a call to procedure P (see
2903 -- Split_Unconstrained_Function).
2909 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2913 Blk_Stmt
: constant Node_Id
:=
2914 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
2915 First_Stmt
: constant Node_Id
:=
2916 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
2917 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
2921 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
2922 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
2923 and then No
(Next
(Second_Stmt
)));
2928 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
2929 Empty
, Instantiating
=> True);
2932 -- Capture the name of the local variable that holds the
2933 -- result. This must be the first declaration in the block,
2934 -- because its bounds cannot depend on local variables.
2935 -- Otherwise there is no way to declare the result outside
2936 -- of the block. Needless to say, in general the bounds will
2937 -- depend on the actuals in the call.
2939 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2940 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
2942 -- If the context is an assignment statement, as is the case
2943 -- for the expansion of an extended return, the left-hand
2944 -- side provides bounds even if the return type is
2948 Targ1
:= Name
(Parent
(N
));
2953 if No
(Declarations
(Bod
)) then
2954 Set_Declarations
(Blk
, New_List
);
2959 -- If this is a derived function, establish the proper return type
2961 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
2962 Ret_Type
:= Etype
(Orig_Subp
);
2964 Ret_Type
:= Etype
(Subp
);
2967 -- Create temporaries for the actuals that are expressions, or that are
2968 -- scalars and require copying to preserve semantics.
2970 F
:= First_Formal
(Subp
);
2971 A
:= First_Actual
(N
);
2972 while Present
(F
) loop
2973 if Present
(Renamed_Object
(F
)) then
2975 -- If expander is active, it is an error to try to inline a
2976 -- recursive program. In GNATprove mode, just indicate that the
2977 -- inlining will not happen, and mark the subprogram as not always
2980 if GNATprove_Mode
then
2982 ("cannot inline call to recursive subprogram?", N
, Subp
);
2983 Set_Is_Inlined_Always
(Subp
, False);
2986 ("cannot inline call to recursive subprogram", N
);
2992 -- Reset Last_Assignment for any parameters of mode out or in out, to
2993 -- prevent spurious warnings about overwriting for assignments to the
2994 -- formal in the inlined code.
2996 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
2997 Set_Last_Assignment
(Entity
(A
), Empty
);
3000 -- If the argument may be a controlling argument in a call within
3001 -- the inlined body, we must preserve its classwide nature to insure
3002 -- that dynamic dispatching take place subsequently. If the formal
3003 -- has a constraint it must be preserved to retain the semantics of
3006 if Is_Class_Wide_Type
(Etype
(F
))
3007 or else (Is_Access_Type
(Etype
(F
))
3008 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3010 Temp_Typ
:= Etype
(F
);
3012 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3013 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3014 and then Is_Constrained
(Etype
(F
))
3016 Temp_Typ
:= Etype
(F
);
3019 Temp_Typ
:= Etype
(A
);
3022 -- If the actual is a simple name or a literal, no need to
3023 -- create a temporary, object can be used directly.
3025 -- If the actual is a literal and the formal has its address taken,
3026 -- we cannot pass the literal itself as an argument, so its value
3027 -- must be captured in a temporary. Skip this optimization in
3028 -- GNATprove mode, to make sure any check on a type conversion
3031 if (Is_Entity_Name
(A
)
3033 (not Is_Scalar_Type
(Etype
(A
))
3034 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
)
3035 and then not GNATprove_Mode
)
3037 -- When the actual is an identifier and the corresponding formal is
3038 -- used only once in the original body, the formal can be substituted
3039 -- directly with the actual parameter. Skip this optimization in
3040 -- GNATprove mode, to make sure any check on a type conversion
3044 (Nkind
(A
) = N_Identifier
3045 and then Formal_Is_Used_Once
(F
)
3046 and then not GNATprove_Mode
)
3049 (Nkind_In
(A
, N_Real_Literal
,
3051 N_Character_Literal
)
3052 and then not Address_Taken
(F
))
3054 if Etype
(F
) /= Etype
(A
) then
3056 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3058 Set_Renamed_Object
(F
, A
);
3062 Temp
:= Make_Temporary
(Loc
, 'C');
3064 -- If the actual for an in/in-out parameter is a view conversion,
3065 -- make it into an unchecked conversion, given that an untagged
3066 -- type conversion is not a proper object for a renaming.
3068 -- In-out conversions that involve real conversions have already
3069 -- been transformed in Expand_Actuals.
3071 if Nkind
(A
) = N_Type_Conversion
3072 and then Ekind
(F
) /= E_In_Parameter
3075 Make_Unchecked_Type_Conversion
(Loc
,
3076 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3077 Expression
=> Relocate_Node
(Expression
(A
)));
3079 -- In GNATprove mode, keep the most precise type of the actual for
3080 -- the temporary variable, when the formal type is unconstrained.
3081 -- Otherwise, the AST may contain unexpected assignment statements
3082 -- to a temporary variable of unconstrained type renaming a local
3083 -- variable of constrained type, which is not expected by
3086 elsif Etype
(F
) /= Etype
(A
)
3087 and then (not GNATprove_Mode
or else Is_Constrained
(Etype
(F
)))
3089 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3090 Temp_Typ
:= Etype
(F
);
3093 New_A
:= Relocate_Node
(A
);
3096 Set_Sloc
(New_A
, Sloc
(N
));
3098 -- If the actual has a by-reference type, it cannot be copied,
3099 -- so its value is captured in a renaming declaration. Otherwise
3100 -- declare a local constant initialized with the actual.
3102 -- We also use a renaming declaration for expressions of an array
3103 -- type that is not bit-packed, both for efficiency reasons and to
3104 -- respect the semantics of the call: in most cases the original
3105 -- call will pass the parameter by reference, and thus the inlined
3106 -- code will have the same semantics.
3108 -- Finally, we need a renaming declaration in the case of limited
3109 -- types for which initialization cannot be by copy either.
3111 if Ekind
(F
) = E_In_Parameter
3112 and then not Is_By_Reference_Type
(Etype
(A
))
3113 and then not Is_Limited_Type
(Etype
(A
))
3115 (not Is_Array_Type
(Etype
(A
))
3116 or else not Is_Object_Reference
(A
)
3117 or else Is_Bit_Packed_Array
(Etype
(A
)))
3120 Make_Object_Declaration
(Loc
,
3121 Defining_Identifier
=> Temp
,
3122 Constant_Present
=> True,
3123 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3124 Expression
=> New_A
);
3127 -- In GNATprove mode, make an explicit copy of input
3128 -- parameters when formal and actual types differ, to make
3129 -- sure any check on the type conversion will be issued.
3130 -- The legality of the copy is ensured by calling first
3131 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3134 and then Ekind
(F
) /= E_Out_Parameter
3135 and then not Same_Type
(Etype
(F
), Etype
(A
))
3137 pragma Assert
(not (Is_By_Reference_Type
(Etype
(A
))));
3138 pragma Assert
(not (Is_Limited_Type
(Etype
(A
))));
3141 Make_Object_Declaration
(Loc
,
3142 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
3143 Constant_Present
=> True,
3144 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3145 Expression
=> New_Copy_Tree
(New_A
)));
3149 Make_Object_Renaming_Declaration
(Loc
,
3150 Defining_Identifier
=> Temp
,
3151 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3155 Append
(Decl
, Decls
);
3156 Set_Renamed_Object
(F
, Temp
);
3163 -- Establish target of function call. If context is not assignment or
3164 -- declaration, create a temporary as a target. The declaration for the
3165 -- temporary may be subsequently optimized away if the body is a single
3166 -- expression, or if the left-hand side of the assignment is simple
3167 -- enough, i.e. an entity or an explicit dereference of one.
3169 if Ekind
(Subp
) = E_Function
then
3170 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3171 and then Is_Entity_Name
(Name
(Parent
(N
)))
3173 Targ
:= Name
(Parent
(N
));
3175 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3176 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3177 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3179 Targ
:= Name
(Parent
(N
));
3181 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3182 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3183 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3185 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3187 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3188 and then Is_Limited_Type
(Etype
(Subp
))
3190 Targ
:= Defining_Identifier
(Parent
(N
));
3192 -- New semantics: In an object declaration avoid an extra copy
3193 -- of the result of a call to an inlined function that returns
3194 -- an unconstrained type
3196 elsif Back_End_Inlining
3197 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3200 Targ
:= Defining_Identifier
(Parent
(N
));
3203 -- Replace call with temporary and create its declaration
3205 Temp
:= Make_Temporary
(Loc
, 'C');
3206 Set_Is_Internal
(Temp
);
3208 -- For the unconstrained case, the generated temporary has the
3209 -- same constrained declaration as the result variable. It may
3210 -- eventually be possible to remove that temporary and use the
3211 -- result variable directly.
3213 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3216 Make_Object_Declaration
(Loc
,
3217 Defining_Identifier
=> Temp
,
3218 Object_Definition
=>
3219 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3221 Replace_Formals
(Decl
);
3225 Make_Object_Declaration
(Loc
,
3226 Defining_Identifier
=> Temp
,
3227 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
3229 Set_Etype
(Temp
, Ret_Type
);
3232 Set_No_Initialization
(Decl
);
3233 Append
(Decl
, Decls
);
3234 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3239 Insert_Actions
(N
, Decls
);
3243 -- Special management for inlining a call to a function that returns
3244 -- an unconstrained type and initializes an object declaration: we
3245 -- avoid generating undesired extra calls and goto statements.
3248 -- function Func (...) return ...
3251 -- Result : String (1 .. 4);
3253 -- Proc (Result, ...);
3258 -- Result : String := Func (...);
3260 -- Replace this object declaration by:
3262 -- Result : String (1 .. 4);
3263 -- Proc (Result, ...);
3265 Remove_Homonym
(Targ
);
3268 Make_Object_Declaration
3270 Defining_Identifier
=> Targ
,
3271 Object_Definition
=>
3272 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3273 Replace_Formals
(Decl
);
3274 Rewrite
(Parent
(N
), Decl
);
3275 Analyze
(Parent
(N
));
3277 -- Avoid spurious warnings since we know that this declaration is
3278 -- referenced by the procedure call.
3280 Set_Never_Set_In_Source
(Targ
, False);
3282 -- Remove the local declaration of the extended return stmt from the
3285 Remove
(Parent
(Targ1
));
3287 -- Update the reference to the result (since we have rewriten the
3288 -- object declaration)
3291 Blk_Call_Stmt
: Node_Id
;
3294 -- Capture the call to the procedure
3297 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3299 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
3301 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
3302 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
3303 New_Occurrence_Of
(Targ
, Loc
));
3306 -- Remove the return statement
3309 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3310 N_Simple_Return_Statement
);
3312 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3315 -- Traverse the tree and replace formals with actuals or their thunks.
3316 -- Attach block to tree before analysis and rewriting.
3318 Replace_Formals
(Blk
);
3319 Set_Parent
(Blk
, N
);
3321 if GNATprove_Mode
then
3324 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
3330 -- No action needed since return statement has been already removed
3334 elsif Present
(Exit_Lab
) then
3336 -- If there's a single return statement at the end of the subprogram,
3337 -- the corresponding goto statement and the corresponding label are
3342 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3345 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3347 Append
(Lab_Decl
, (Declarations
(Blk
)));
3348 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3352 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3353 -- on conflicting private views that Gigi would ignore. If this is a
3354 -- predefined unit, analyze with checks off, as is done in the non-
3355 -- inlined run-time units.
3358 I_Flag
: constant Boolean := In_Inlined_Body
;
3361 In_Inlined_Body
:= True;
3365 Style
: constant Boolean := Style_Check
;
3368 Style_Check
:= False;
3370 -- Search for dispatching calls that use the Object.Operation
3371 -- notation using an Object that is a parameter of the inlined
3372 -- function. We reset the decoration of Operation to force
3373 -- the reanalysis of the inlined dispatching call because
3374 -- the actual object has been inlined.
3376 Reset_Dispatching_Calls
(Blk
);
3378 Analyze
(Blk
, Suppress
=> All_Checks
);
3379 Style_Check
:= Style
;
3386 In_Inlined_Body
:= I_Flag
;
3389 if Ekind
(Subp
) = E_Procedure
then
3390 Rewrite_Procedure_Call
(N
, Blk
);
3393 Rewrite_Function_Call
(N
, Blk
);
3398 -- For the unconstrained case, the replacement of the call has been
3399 -- made prior to the complete analysis of the generated declarations.
3400 -- Propagate the proper type now.
3403 if Nkind
(N
) = N_Identifier
then
3404 Set_Etype
(N
, Etype
(Entity
(N
)));
3406 Set_Etype
(N
, Etype
(Targ1
));
3413 -- Cleanup mapping between formals and actuals for other expansions
3415 F
:= First_Formal
(Subp
);
3416 while Present
(F
) loop
3417 Set_Renamed_Object
(F
, Empty
);
3420 end Expand_Inlined_Call
;
3422 --------------------------
3423 -- Get_Code_Unit_Entity --
3424 --------------------------
3426 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
3427 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
3430 if Ekind
(Unit
) = E_Package_Body
then
3431 Unit
:= Spec_Entity
(Unit
);
3435 end Get_Code_Unit_Entity
;
3437 ------------------------------
3438 -- Has_Excluded_Declaration --
3439 ------------------------------
3441 function Has_Excluded_Declaration
3443 Decls
: List_Id
) return Boolean
3447 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
3448 -- Nested subprograms make a given body ineligible for inlining, but
3449 -- we make an exception for instantiations of unchecked conversion.
3450 -- The body has not been analyzed yet, so check the name, and verify
3451 -- that the visible entity with that name is the predefined unit.
3453 -----------------------------
3454 -- Is_Unchecked_Conversion --
3455 -----------------------------
3457 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
3458 Id
: constant Node_Id
:= Name
(D
);
3462 if Nkind
(Id
) = N_Identifier
3463 and then Chars
(Id
) = Name_Unchecked_Conversion
3465 Conv
:= Current_Entity
(Id
);
3467 elsif Nkind_In
(Id
, N_Selected_Component
, N_Expanded_Name
)
3468 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
3470 Conv
:= Current_Entity
(Selector_Name
(Id
));
3475 return Present
(Conv
)
3476 and then Is_Predefined_Unit
(Get_Source_Unit
(Conv
))
3477 and then Is_Intrinsic_Subprogram
(Conv
);
3478 end Is_Unchecked_Conversion
;
3480 -- Start of processing for Has_Excluded_Declaration
3483 -- No action needed if the check is not needed
3485 if not Check_Inlining_Restrictions
then
3490 while Present
(D
) loop
3492 -- First declarations universally excluded
3494 if Nkind
(D
) = N_Package_Declaration
then
3496 ("cannot inline & (nested package declaration)?", D
, Subp
);
3499 elsif Nkind
(D
) = N_Package_Instantiation
then
3501 ("cannot inline & (nested package instantiation)?", D
, Subp
);
3505 -- Then declarations excluded only for front end inlining
3507 if Back_End_Inlining
then
3510 elsif Nkind
(D
) = N_Task_Type_Declaration
3511 or else Nkind
(D
) = N_Single_Task_Declaration
3514 ("cannot inline & (nested task type declaration)?", D
, Subp
);
3517 elsif Nkind
(D
) = N_Protected_Type_Declaration
3518 or else Nkind
(D
) = N_Single_Protected_Declaration
3521 ("cannot inline & (nested protected type declaration)?",
3525 elsif Nkind
(D
) = N_Subprogram_Body
then
3527 ("cannot inline & (nested subprogram)?", D
, Subp
);
3530 elsif Nkind
(D
) = N_Function_Instantiation
3531 and then not Is_Unchecked_Conversion
(D
)
3534 ("cannot inline & (nested function instantiation)?", D
, Subp
);
3537 elsif Nkind
(D
) = N_Procedure_Instantiation
then
3539 ("cannot inline & (nested procedure instantiation)?", D
, Subp
);
3542 -- Subtype declarations with predicates will generate predicate
3543 -- functions, i.e. nested subprogram bodies, so inlining is not
3546 elsif Nkind
(D
) = N_Subtype_Declaration
3547 and then Present
(Aspect_Specifications
(D
))
3554 A
:= First
(Aspect_Specifications
(D
));
3555 while Present
(A
) loop
3556 A_Id
:= Get_Aspect_Id
(Chars
(Identifier
(A
)));
3558 if A_Id
= Aspect_Predicate
3559 or else A_Id
= Aspect_Static_Predicate
3560 or else A_Id
= Aspect_Dynamic_Predicate
3563 ("cannot inline & (subtype declaration with "
3564 & "predicate)?", D
, Subp
);
3577 end Has_Excluded_Declaration
;
3579 ----------------------------
3580 -- Has_Excluded_Statement --
3581 ----------------------------
3583 function Has_Excluded_Statement
3585 Stats
: List_Id
) return Boolean
3591 -- No action needed if the check is not needed
3593 if not Check_Inlining_Restrictions
then
3598 while Present
(S
) loop
3599 if Nkind_In
(S
, N_Abort_Statement
,
3600 N_Asynchronous_Select
,
3601 N_Conditional_Entry_Call
,
3602 N_Delay_Relative_Statement
,
3603 N_Delay_Until_Statement
,
3608 ("cannot inline & (non-allowed statement)?", S
, Subp
);
3611 elsif Nkind
(S
) = N_Block_Statement
then
3612 if Present
(Declarations
(S
))
3613 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
3617 elsif Present
(Handled_Statement_Sequence
(S
)) then
3618 if not Back_End_Inlining
3621 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
3624 ("cannot inline& (exception handler)?",
3625 First
(Exception_Handlers
3626 (Handled_Statement_Sequence
(S
))),
3630 elsif Has_Excluded_Statement
3631 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3637 elsif Nkind
(S
) = N_Case_Statement
then
3638 E
:= First
(Alternatives
(S
));
3639 while Present
(E
) loop
3640 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
3647 elsif Nkind
(S
) = N_If_Statement
then
3648 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
3652 if Present
(Elsif_Parts
(S
)) then
3653 E
:= First
(Elsif_Parts
(S
));
3654 while Present
(E
) loop
3655 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
3663 if Present
(Else_Statements
(S
))
3664 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
3669 elsif Nkind
(S
) = N_Loop_Statement
3670 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
3674 elsif Nkind
(S
) = N_Extended_Return_Statement
then
3675 if Present
(Handled_Statement_Sequence
(S
))
3677 Has_Excluded_Statement
3678 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3682 elsif not Back_End_Inlining
3683 and then Present
(Handled_Statement_Sequence
(S
))
3685 Present
(Exception_Handlers
3686 (Handled_Statement_Sequence
(S
)))
3689 ("cannot inline& (exception handler)?",
3690 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
3700 end Has_Excluded_Statement
;
3702 --------------------------
3703 -- Has_Initialized_Type --
3704 --------------------------
3706 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
3707 E_Body
: constant Node_Id
:= Subprogram_Body
(E
);
3711 if No
(E_Body
) then -- imported subprogram
3715 Decl
:= First
(Declarations
(E_Body
));
3716 while Present
(Decl
) loop
3717 if Nkind
(Decl
) = N_Full_Type_Declaration
3718 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
3728 end Has_Initialized_Type
;
3730 -----------------------
3731 -- Has_Single_Return --
3732 -----------------------
3734 function Has_Single_Return
(N
: Node_Id
) return Boolean is
3735 Return_Statement
: Node_Id
:= Empty
;
3737 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
3743 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
3745 if Nkind
(N
) = N_Simple_Return_Statement
then
3746 if Present
(Expression
(N
))
3747 and then Is_Entity_Name
(Expression
(N
))
3749 if No
(Return_Statement
) then
3750 Return_Statement
:= N
;
3753 elsif Chars
(Expression
(N
)) =
3754 Chars
(Expression
(Return_Statement
))
3762 -- A return statement within an extended return is a noop
3765 elsif No
(Expression
(N
))
3767 Nkind
(Parent
(Parent
(N
))) = N_Extended_Return_Statement
3772 -- Expression has wrong form
3777 -- We can only inline a build-in-place function if it has a single
3780 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3781 if No
(Return_Statement
) then
3782 Return_Statement
:= N
;
3794 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
3796 -- Start of processing for Has_Single_Return
3799 if Check_All_Returns
(N
) /= OK
then
3802 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
3806 return Present
(Declarations
(N
))
3807 and then Present
(First
(Declarations
(N
)))
3808 and then Chars
(Expression
(Return_Statement
)) =
3809 Chars
(Defining_Identifier
(First
(Declarations
(N
))));
3811 end Has_Single_Return
;
3813 -----------------------------
3814 -- In_Main_Unit_Or_Subunit --
3815 -----------------------------
3817 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
3818 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
3821 -- Check whether the subprogram or package to inline is within the main
3822 -- unit or its spec or within a subunit. In either case there are no
3823 -- additional bodies to process. If the subprogram appears in a parent
3824 -- of the current unit, the check on whether inlining is possible is
3825 -- done in Analyze_Inlined_Bodies.
3827 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
3828 Comp
:= Library_Unit
(Comp
);
3831 return Comp
= Cunit
(Main_Unit
)
3832 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
3833 end In_Main_Unit_Or_Subunit
;
3839 procedure Initialize
is
3841 Pending_Descriptor
.Init
;
3842 Pending_Instantiations
.Init
;
3843 Inlined_Bodies
.Init
;
3847 for J
in Hash_Headers
'Range loop
3848 Hash_Headers
(J
) := No_Subp
;
3851 Inlined_Calls
:= No_Elist
;
3852 Backend_Calls
:= No_Elist
;
3853 Backend_Inlined_Subps
:= No_Elist
;
3854 Backend_Not_Inlined_Subps
:= No_Elist
;
3857 ------------------------
3858 -- Instantiate_Bodies --
3859 ------------------------
3861 -- Generic bodies contain all the non-local references, so an
3862 -- instantiation does not need any more context than Standard
3863 -- itself, even if the instantiation appears in an inner scope.
3864 -- Generic associations have verified that the contract model is
3865 -- satisfied, so that any error that may occur in the analysis of
3866 -- the body is an internal error.
3868 procedure Instantiate_Bodies
is
3870 Info
: Pending_Body_Info
;
3873 if Serious_Errors_Detected
= 0 then
3874 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
3875 Push_Scope
(Standard_Standard
);
3876 To_Clean
:= New_Elmt_List
;
3878 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3882 -- A body instantiation may generate additional instantiations, so
3883 -- the following loop must scan to the end of a possibly expanding
3884 -- set (that's why we can't simply use a FOR loop here).
3887 while J
<= Pending_Instantiations
.Last
3888 and then Serious_Errors_Detected
= 0
3890 Info
:= Pending_Instantiations
.Table
(J
);
3892 -- If the instantiation node is absent, it has been removed
3893 -- as part of unreachable code.
3895 if No
(Info
.Inst_Node
) then
3898 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
3899 Instantiate_Package_Body
(Info
);
3900 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
3903 Instantiate_Subprogram_Body
(Info
);
3909 -- Reset the table of instantiations. Additional instantiations
3910 -- may be added through inlining, when additional bodies are
3913 Pending_Instantiations
.Init
;
3915 -- We can now complete the cleanup actions of scopes that contain
3916 -- pending instantiations (skipped for generic units, since we
3917 -- never need any cleanups in generic units).
3920 and then not Is_Generic_Unit
(Main_Unit_Entity
)
3923 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3929 end Instantiate_Bodies
;
3935 function Is_Nested
(E
: Entity_Id
) return Boolean is
3940 while Scop
/= Standard_Standard
loop
3941 if Ekind
(Scop
) in Subprogram_Kind
then
3944 elsif Ekind
(Scop
) = E_Task_Type
3945 or else Ekind
(Scop
) = E_Entry
3946 or else Ekind
(Scop
) = E_Entry_Family
3951 Scop
:= Scope
(Scop
);
3957 ------------------------
3958 -- List_Inlining_Info --
3959 ------------------------
3961 procedure List_Inlining_Info
is
3967 if not Debug_Flag_Dot_J
then
3971 -- Generate listing of calls inlined by the frontend
3973 if Present
(Inlined_Calls
) then
3975 Elmt
:= First_Elmt
(Inlined_Calls
);
3976 while Present
(Elmt
) loop
3979 if In_Extended_Main_Code_Unit
(Nod
) then
3983 Write_Str
("List of calls inlined by the frontend");
3990 Write_Location
(Sloc
(Nod
));
3999 -- Generate listing of calls passed to the backend
4001 if Present
(Backend_Calls
) then
4004 Elmt
:= First_Elmt
(Backend_Calls
);
4005 while Present
(Elmt
) loop
4008 if In_Extended_Main_Code_Unit
(Nod
) then
4012 Write_Str
("List of inlined calls passed to the backend");
4019 Write_Location
(Sloc
(Nod
));
4027 -- Generate listing of subprograms passed to the backend
4029 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
4032 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
4033 while Present
(Elmt
) loop
4040 ("List of inlined subprograms passed to the backend");
4047 Write_Name
(Chars
(Nod
));
4049 Write_Location
(Sloc
(Nod
));
4057 -- Generate listing of subprograms that cannot be inlined by the backend
4059 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
4062 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
4063 while Present
(Elmt
) loop
4070 ("List of subprograms that cannot be inlined by the backend");
4077 Write_Name
(Chars
(Nod
));
4079 Write_Location
(Sloc
(Nod
));
4086 end List_Inlining_Info
;
4094 Pending_Instantiations
.Release
;
4095 Pending_Instantiations
.Locked
:= True;
4096 Inlined_Bodies
.Release
;
4097 Inlined_Bodies
.Locked
:= True;
4099 Successors
.Locked
:= True;
4101 Inlined
.Locked
:= True;
4104 --------------------------------
4105 -- Remove_Aspects_And_Pragmas --
4106 --------------------------------
4108 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
4109 procedure Remove_Items
(List
: List_Id
);
4110 -- Remove all useless aspects/pragmas from a particular list
4116 procedure Remove_Items
(List
: List_Id
) is
4119 Next_Item
: Node_Id
;
4122 -- Traverse the list looking for an aspect specification or a pragma
4124 Item
:= First
(List
);
4125 while Present
(Item
) loop
4126 Next_Item
:= Next
(Item
);
4128 if Nkind
(Item
) = N_Aspect_Specification
then
4129 Item_Id
:= Identifier
(Item
);
4130 elsif Nkind
(Item
) = N_Pragma
then
4131 Item_Id
:= Pragma_Identifier
(Item
);
4136 if Present
(Item_Id
)
4137 and then Nam_In
(Chars
(Item_Id
), Name_Contract_Cases
,
4142 Name_Refined_Global
,
4143 Name_Refined_Depends
,
4157 -- Start of processing for Remove_Aspects_And_Pragmas
4160 Remove_Items
(Aspect_Specifications
(Body_Decl
));
4161 Remove_Items
(Declarations
(Body_Decl
));
4163 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4164 -- in the body of the subprogram.
4166 Remove_Items
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
4167 end Remove_Aspects_And_Pragmas
;
4169 --------------------------
4170 -- Remove_Dead_Instance --
4171 --------------------------
4173 procedure Remove_Dead_Instance
(N
: Node_Id
) is
4178 while J
<= Pending_Instantiations
.Last
loop
4179 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
4180 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
4186 end Remove_Dead_Instance
;