1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Debug
; use Debug
;
28 with Einfo
; use Einfo
;
29 with Elists
; use Elists
;
30 with Errout
; use Errout
;
31 with Expander
; use Expander
;
32 with Exp_Ch6
; use Exp_Ch6
;
33 with Exp_Ch7
; use Exp_Ch7
;
34 with Exp_Tss
; use Exp_Tss
;
35 with Exp_Util
; use Exp_Util
;
36 with Fname
; use Fname
;
37 with Fname
.UF
; use Fname
.UF
;
39 with Namet
; use Namet
;
40 with Nmake
; use Nmake
;
41 with Nlists
; use Nlists
;
42 with Output
; use Output
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Ch10
; use Sem_Ch10
;
46 with Sem_Ch12
; use Sem_Ch12
;
47 with Sem_Prag
; use Sem_Prag
;
48 with Sem_Util
; use Sem_Util
;
49 with Sinfo
; use Sinfo
;
50 with Sinput
; use Sinput
;
51 with Snames
; use Snames
;
52 with Stand
; use Stand
;
53 with Uname
; use Uname
;
54 with Tbuild
; use Tbuild
;
56 package body Inline
is
58 Check_Inlining_Restrictions
: constant Boolean := True;
59 -- In the following cases the frontend rejects inlining because they
60 -- are not handled well by the backend. This variable facilitates
61 -- disabling these restrictions to evaluate future versions of the
62 -- GCC backend in which some of the restrictions may be supported.
64 -- - subprograms that have:
65 -- - nested subprograms
67 -- - package declarations
68 -- - task or protected object declarations
69 -- - some of the following statements:
71 -- - asynchronous-select
72 -- - conditional-entry-call
78 Inlined_Calls
: Elist_Id
;
79 -- List of frontend inlined calls
81 Backend_Calls
: Elist_Id
;
82 -- List of inline calls passed to the backend
84 Backend_Inlined_Subps
: Elist_Id
;
85 -- List of subprograms inlined by the backend
87 Backend_Not_Inlined_Subps
: Elist_Id
;
88 -- List of subprograms that cannot be inlined by the backend
94 -- Inlined functions are actually placed in line by the backend if the
95 -- corresponding bodies are available (i.e. compiled). Whenever we find
96 -- a call to an inlined subprogram, we add the name of the enclosing
97 -- compilation unit to a worklist. After all compilation, and after
98 -- expansion of generic bodies, we traverse the list of pending bodies
99 -- and compile them as well.
101 package Inlined_Bodies
is new Table
.Table
(
102 Table_Component_Type
=> Entity_Id
,
103 Table_Index_Type
=> Int
,
104 Table_Low_Bound
=> 0,
105 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
106 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
107 Table_Name
=> "Inlined_Bodies");
109 -----------------------
110 -- Inline Processing --
111 -----------------------
113 -- For each call to an inlined subprogram, we make entries in a table
114 -- that stores caller and callee, and indicates the call direction from
115 -- one to the other. We also record the compilation unit that contains
116 -- the callee. After analyzing the bodies of all such compilation units,
117 -- we compute the transitive closure of inlined subprograms called from
118 -- the main compilation unit and make it available to the code generator
119 -- in no particular order, thus allowing cycles in the call graph.
121 Last_Inlined
: Entity_Id
:= Empty
;
123 -- For each entry in the table we keep a list of successors in topological
124 -- order, i.e. callers of the current subprogram.
126 type Subp_Index
is new Nat
;
127 No_Subp
: constant Subp_Index
:= 0;
129 -- The subprogram entities are hashed into the Inlined table
131 Num_Hash_Headers
: constant := 512;
133 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
136 type Succ_Index
is new Nat
;
137 No_Succ
: constant Succ_Index
:= 0;
139 type Succ_Info
is record
144 -- The following table stores list elements for the successor lists. These
145 -- lists cannot be chained directly through entries in the Inlined table,
146 -- because a given subprogram can appear in several such lists.
148 package Successors
is new Table
.Table
(
149 Table_Component_Type
=> Succ_Info
,
150 Table_Index_Type
=> Succ_Index
,
151 Table_Low_Bound
=> 1,
152 Table_Initial
=> Alloc
.Successors_Initial
,
153 Table_Increment
=> Alloc
.Successors_Increment
,
154 Table_Name
=> "Successors");
156 type Subp_Info
is record
157 Name
: Entity_Id
:= Empty
;
158 Next
: Subp_Index
:= No_Subp
;
159 First_Succ
: Succ_Index
:= No_Succ
;
160 Listed
: Boolean := False;
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
(Index
: Subp_Index
);
183 -- Add the subprogram 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 -- non-trivial 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_Pragmas
(Bod
: Node_Id
);
216 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
217 -- parameter has no meaning when the body is inlined and the formals
218 -- are rewritten. Remove it from body to inline. The analysis of the
219 -- non-inlined body will handle the pragma properly.
221 ------------------------------
222 -- Deferred Cleanup Actions --
223 ------------------------------
225 -- The cleanup actions for scopes that contain instantiations is delayed
226 -- until after expansion of those instantiations, because they may contain
227 -- finalizable objects or tasks that affect the cleanup code. A scope
228 -- that contains instantiations only needs to be finalized once, even
229 -- if it contains more than one instance. We keep a list of scopes
230 -- that must still be finalized, and call cleanup_actions after all
231 -- the instantiations have been completed.
235 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
236 -- Build set of scopes on which cleanup actions must be performed
238 procedure Cleanup_Scopes
;
239 -- Complete cleanup actions on scopes that need it
245 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
246 P1
: constant Subp_Index
:= Add_Subp
(Called
);
251 if Present
(Caller
) then
252 P2
:= Add_Subp
(Caller
);
254 -- Add P1 to the list of successors of P2, if not already there.
255 -- Note that P2 may contain more than one call to P1, and only
256 -- one needs to be recorded.
258 J
:= Inlined
.Table
(P2
).First_Succ
;
259 while J
/= No_Succ
loop
260 if Successors
.Table
(J
).Subp
= P1
then
264 J
:= Successors
.Table
(J
).Next
;
267 -- On exit, make a successor entry for P1
269 Successors
.Increment_Last
;
270 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
271 Successors
.Table
(Successors
.Last
).Next
:=
272 Inlined
.Table
(P2
).First_Succ
;
273 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
275 Inlined
.Table
(P1
).Main_Call
:= True;
279 ----------------------
280 -- Add_Inlined_Body --
281 ----------------------
283 procedure Add_Inlined_Body
(E
: Entity_Id
) is
285 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
286 -- Level of inlining for the call: Dont_Inline means no inlining,
287 -- Inline_Call means that only the call is considered for inlining,
288 -- Inline_Package means that the call is considered for inlining and
289 -- its package compiled and scanned for more inlining opportunities.
291 function Must_Inline
return Inline_Level_Type
;
292 -- Inlining is only done if the call statement N is in the main unit,
293 -- or within the body of another inlined subprogram.
299 function Must_Inline
return Inline_Level_Type
is
304 -- Check if call is in main unit
306 Scop
:= Current_Scope
;
308 -- Do not try to inline if scope is standard. This could happen, for
309 -- example, for a call to Add_Global_Declaration, and it causes
310 -- trouble to try to inline at this level.
312 if Scop
= Standard_Standard
then
316 -- Otherwise lookup scope stack to outer scope
318 while Scope
(Scop
) /= Standard_Standard
319 and then not Is_Child_Unit
(Scop
)
321 Scop
:= Scope
(Scop
);
324 Comp
:= Parent
(Scop
);
325 while Nkind
(Comp
) /= N_Compilation_Unit
loop
326 Comp
:= Parent
(Comp
);
329 -- If the call is in the main unit, inline the call and compile the
330 -- package of the subprogram to find more calls to be inlined.
332 if Comp
= Cunit
(Main_Unit
)
333 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
336 return Inline_Package
;
339 -- The call is not in the main unit. See if it is in some inlined
340 -- subprogram. If so, inline the call and, if the inlining level is
341 -- set to 1, stop there; otherwise also compile the package as above.
343 Scop
:= Current_Scope
;
344 while Scope
(Scop
) /= Standard_Standard
345 and then not Is_Child_Unit
(Scop
)
347 if Is_Overloadable
(Scop
) and then Is_Inlined
(Scop
) then
350 if Inline_Level
= 1 then
353 return Inline_Package
;
357 Scop
:= Scope
(Scop
);
363 Level
: Inline_Level_Type
;
365 -- Start of processing for Add_Inlined_Body
368 -- Find unit containing E, and add to list of inlined bodies if needed.
369 -- If the body is already present, no need to load any other unit. This
370 -- is the case for an initialization procedure, which appears in the
371 -- package declaration that contains the type. It is also the case if
372 -- the body has already been analyzed. Finally, if the unit enclosing
373 -- E is an instance, the instance body will be analyzed in any case,
374 -- and there is no need to add the enclosing unit (whose body might not
377 -- Library-level functions must be handled specially, because there is
378 -- no enclosing package to retrieve. In this case, it is the body of
379 -- the function that will have to be loaded.
381 if Is_Abstract_Subprogram
(E
)
382 or else Is_Nested
(E
)
383 or else Convention
(E
) = Convention_Protected
388 Level
:= Must_Inline
;
389 if Level
/= Dont_Inline
then
391 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
396 -- Library-level inlined function. Add function itself to
397 -- list of needed units.
400 Inlined_Bodies
.Increment_Last
;
401 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
403 elsif Ekind
(Pack
) = E_Package
then
406 if Is_Generic_Instance
(Pack
) then
409 -- Do not inline the package if the subprogram is an init proc
410 -- or other internally generated subprogram, because in that
411 -- case the subprogram body appears in the same unit that
412 -- declares the type, and that body is visible to the back end.
413 -- Do not inline it either if it is in the main unit.
415 elsif Level
= Inline_Package
416 and then not Is_Inlined
(Pack
)
417 and then not Is_Internal
(E
)
418 and then not In_Main_Unit_Or_Subunit
(Pack
)
420 Set_Is_Inlined
(Pack
);
421 Inlined_Bodies
.Increment_Last
;
422 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
424 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
425 -- calls if the back-end takes care of inlining the call.
427 elsif Level
= Inline_Call
428 and then Has_Pragma_Inline_Always
(E
)
429 and then Back_End_Inlining
431 Set_Is_Inlined
(Pack
);
432 Inlined_Bodies
.Increment_Last
;
433 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
438 end Add_Inlined_Body
;
440 ----------------------------
441 -- Add_Inlined_Subprogram --
442 ----------------------------
444 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
445 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
446 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
448 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
449 -- Append Subp to the list of subprograms inlined by the backend
451 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
452 -- Append Subp to the list of subprograms that cannot be inlined by
455 -----------------------------------------
456 -- Register_Backend_Inlined_Subprogram --
457 -----------------------------------------
459 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
461 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
462 end Register_Backend_Inlined_Subprogram
;
464 ---------------------------------------------
465 -- Register_Backend_Not_Inlined_Subprogram --
466 ---------------------------------------------
468 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
470 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
471 end Register_Backend_Not_Inlined_Subprogram
;
473 -- Start of processing for Add_Inlined_Subprogram
476 -- If the subprogram is to be inlined, and if its unit is known to be
477 -- inlined or is an instance whose body will be analyzed anyway or the
478 -- subprogram has been generated by the compiler, and if it is declared
479 -- at the library level not in the main unit, and if it can be inlined
480 -- by the back-end, then insert it in the list of inlined subprograms.
483 and then (Is_Inlined
(Pack
)
484 or else Is_Generic_Instance
(Pack
)
485 or else Is_Internal
(E
))
486 and then not In_Main_Unit_Or_Subunit
(E
)
487 and then not Is_Nested
(E
)
488 and then not Has_Initialized_Type
(E
)
490 Register_Backend_Inlined_Subprogram
(E
);
492 if No
(Last_Inlined
) then
493 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
495 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
500 Register_Backend_Not_Inlined_Subprogram
(E
);
503 Inlined
.Table
(Index
).Listed
:= True;
504 end Add_Inlined_Subprogram
;
506 ------------------------
507 -- Add_Scope_To_Clean --
508 ------------------------
510 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
511 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
515 -- If the instance appears in a library-level package declaration,
516 -- all finalization is global, and nothing needs doing here.
518 if Scop
= Standard_Standard
then
522 -- If the instance is within a generic unit, no finalization code
523 -- can be generated. Note that at this point all bodies have been
524 -- analyzed, and the scope stack itself is not present, and the flag
525 -- Inside_A_Generic is not set.
532 while Present
(S
) and then S
/= Standard_Standard
loop
533 if Is_Generic_Unit
(S
) then
541 Elmt
:= First_Elmt
(To_Clean
);
542 while Present
(Elmt
) loop
543 if Node
(Elmt
) = Scop
then
547 Elmt
:= Next_Elmt
(Elmt
);
550 Append_Elmt
(Scop
, To_Clean
);
551 end Add_Scope_To_Clean
;
557 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
558 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
562 -- Initialize entry in Inlined table
564 procedure New_Entry
is
566 Inlined
.Increment_Last
;
567 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
568 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
569 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
570 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
571 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
572 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
575 -- Start of processing for Add_Subp
578 if Hash_Headers
(Index
) = No_Subp
then
580 Hash_Headers
(Index
) := Inlined
.Last
;
584 J
:= Hash_Headers
(Index
);
585 while J
/= No_Subp
loop
586 if Inlined
.Table
(J
).Name
= E
then
590 J
:= Inlined
.Table
(J
).Next
;
594 -- On exit, subprogram was not found. Enter in table. Index is
595 -- the current last entry on the hash chain.
598 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
603 ----------------------------
604 -- Analyze_Inlined_Bodies --
605 ----------------------------
607 procedure Analyze_Inlined_Bodies
is
614 type Pending_Index
is new Nat
;
616 package Pending_Inlined
is new Table
.Table
(
617 Table_Component_Type
=> Subp_Index
,
618 Table_Index_Type
=> Pending_Index
,
619 Table_Low_Bound
=> 1,
620 Table_Initial
=> Alloc
.Inlined_Initial
,
621 Table_Increment
=> Alloc
.Inlined_Increment
,
622 Table_Name
=> "Pending_Inlined");
623 -- The workpile used to compute the transitive closure
625 function Is_Ancestor_Of_Main
627 Nam
: Node_Id
) return Boolean;
628 -- Determine whether the unit whose body is loaded is an ancestor of
629 -- the main unit, and has a with_clause on it. The body is not
630 -- analyzed yet, so the check is purely lexical: the name of the with
631 -- clause is a selected component, and names of ancestors must match.
633 -------------------------
634 -- Is_Ancestor_Of_Main --
635 -------------------------
637 function Is_Ancestor_Of_Main
639 Nam
: Node_Id
) return Boolean
644 if Nkind
(Nam
) /= N_Selected_Component
then
648 if Chars
(Selector_Name
(Nam
)) /=
649 Chars
(Cunit_Entity
(Main_Unit
))
654 Pref
:= Prefix
(Nam
);
655 if Nkind
(Pref
) = N_Identifier
then
657 -- Par is an ancestor of Par.Child.
659 return Chars
(Pref
) = Chars
(U_Name
);
661 elsif Nkind
(Pref
) = N_Selected_Component
662 and then Chars
(Selector_Name
(Pref
)) = Chars
(U_Name
)
664 -- Par.Child is an ancestor of Par.Child.Grand.
666 return True; -- should check that ancestor match
669 -- A is an ancestor of A.B.C if it is an ancestor of A.B
671 return Is_Ancestor_Of_Main
(U_Name
, Pref
);
674 end Is_Ancestor_Of_Main
;
676 -- Start of processing for Analyze_Inlined_Bodies
679 if Serious_Errors_Detected
= 0 then
680 Push_Scope
(Standard_Standard
);
683 while J
<= Inlined_Bodies
.Last
684 and then Serious_Errors_Detected
= 0
686 Pack
:= Inlined_Bodies
.Table
(J
);
688 and then Scope
(Pack
) /= Standard_Standard
689 and then not Is_Child_Unit
(Pack
)
691 Pack
:= Scope
(Pack
);
694 Comp_Unit
:= Parent
(Pack
);
695 while Present
(Comp_Unit
)
696 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
698 Comp_Unit
:= Parent
(Comp_Unit
);
701 -- Load the body, unless it is the main unit, or is an instance
702 -- whose body has already been analyzed.
704 if Present
(Comp_Unit
)
705 and then Comp_Unit
/= Cunit
(Main_Unit
)
706 and then Body_Required
(Comp_Unit
)
707 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
708 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
711 Bname
: constant Unit_Name_Type
:=
712 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
717 if not Is_Loaded
(Bname
) then
718 Style_Check
:= False;
719 Load_Needed_Body
(Comp_Unit
, OK
, Do_Analyze
=> False);
723 -- Warn that a body was not available for inlining
726 Error_Msg_Unit_1
:= Bname
;
728 ("one or more inlined subprograms accessed in $!??",
731 Get_File_Name
(Bname
, Subunit
=> False);
732 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
735 -- If the package to be inlined is an ancestor unit of
736 -- the main unit, and it has a semantic dependence on
737 -- it, the inlining cannot take place to prevent an
738 -- elaboration circularity. The desired body is not
739 -- analyzed yet, to prevent the completion of Taft
740 -- amendment types that would lead to elaboration
741 -- circularities in gigi.
744 U_Id
: constant Entity_Id
:=
745 Defining_Entity
(Unit
(Comp_Unit
));
746 Body_Unit
: constant Node_Id
:=
747 Library_Unit
(Comp_Unit
);
751 Item
:= First
(Context_Items
(Body_Unit
));
752 while Present
(Item
) loop
753 if Nkind
(Item
) = N_With_Clause
755 Is_Ancestor_Of_Main
(U_Id
, Name
(Item
))
757 Set_Is_Inlined
(U_Id
, False);
764 -- If no suspicious with_clauses, analyze the body.
766 if Is_Inlined
(U_Id
) then
767 Semantics
(Body_Unit
);
778 -- The analysis of required bodies may have produced additional
779 -- generic instantiations. To obtain further inlining, we perform
780 -- another round of generic body instantiations. Establishing a
781 -- fully recursive loop between inlining and generic instantiations
782 -- is unlikely to yield more than this one additional pass.
786 -- The list of inlined subprograms is an overestimate, because it
787 -- includes inlined functions called from functions that are compiled
788 -- as part of an inlined package, but are not themselves called. An
789 -- accurate computation of just those subprograms that are needed
790 -- requires that we perform a transitive closure over the call graph,
791 -- starting from calls in the main program.
793 for Index
in Inlined
.First
.. Inlined
.Last
loop
794 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
796 -- This means that Add_Inlined_Body added the subprogram to the
797 -- table but wasn't able to handle its code unit. Do nothing.
799 Inlined
.Table
(Index
).Processed
:= True;
801 elsif Inlined
.Table
(Index
).Main_Call
then
802 Pending_Inlined
.Increment_Last
;
803 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
804 Inlined
.Table
(Index
).Processed
:= True;
807 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
811 -- Iterate over the workpile until it is emptied, propagating the
812 -- Is_Called flag to the successors of the processed subprogram.
814 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
815 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
816 Pending_Inlined
.Decrement_Last
;
818 S
:= Inlined
.Table
(Subp
).First_Succ
;
820 while S
/= No_Succ
loop
821 Subp
:= Successors
.Table
(S
).Subp
;
823 if not Inlined
.Table
(Subp
).Processed
then
824 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
825 Pending_Inlined
.Increment_Last
;
826 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
827 Inlined
.Table
(Subp
).Processed
:= True;
830 S
:= Successors
.Table
(S
).Next
;
834 -- Finally add the called subprograms to the list of inlined
835 -- subprograms for the unit.
837 for Index
in Inlined
.First
.. Inlined
.Last
loop
838 if Is_Called
(Inlined
.Table
(Index
).Name
)
839 and then not Inlined
.Table
(Index
).Listed
841 Add_Inlined_Subprogram
(Index
);
847 end Analyze_Inlined_Bodies
;
849 --------------------------
850 -- Build_Body_To_Inline --
851 --------------------------
853 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
854 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
855 Analysis_Status
: constant Boolean := Full_Analysis
;
856 Original_Body
: Node_Id
;
857 Body_To_Analyze
: Node_Id
;
858 Max_Size
: constant := 10;
860 function Has_Pending_Instantiation
return Boolean;
861 -- If some enclosing body contains instantiations that appear before
862 -- the corresponding generic body, the enclosing body has a freeze node
863 -- so that it can be elaborated after the generic itself. This might
864 -- conflict with subsequent inlinings, so that it is unsafe to try to
865 -- inline in such a case.
867 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
868 -- This function is called only in GNATprove mode, and it returns
869 -- True if the subprogram has no return statement or a single return
870 -- statement as last statement. It returns False for subprogram with
871 -- a single return as last statement inside one or more blocks, as
872 -- inlining would generate gotos in that case as well (although the
873 -- goto is useless in that case).
875 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
876 -- If the body of the subprogram includes a call that returns an
877 -- unconstrained type, the secondary stack is involved, and it
878 -- is not worth inlining.
880 -------------------------------
881 -- Has_Pending_Instantiation --
882 -------------------------------
884 function Has_Pending_Instantiation
return Boolean is
889 while Present
(S
) loop
890 if Is_Compilation_Unit
(S
)
891 or else Is_Child_Unit
(S
)
895 elsif Ekind
(S
) = E_Package
896 and then Has_Forward_Instantiation
(S
)
905 end Has_Pending_Instantiation
;
907 -----------------------------------------
908 -- Has_Single_Return_In_GNATprove_Mode --
909 -----------------------------------------
911 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
912 Last_Statement
: Node_Id
:= Empty
;
914 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
915 -- Returns OK on node N if this is not a return statement different
916 -- from the last statement in the subprogram.
922 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
924 if Nkind_In
(N
, N_Simple_Return_Statement
,
925 N_Extended_Return_Statement
)
927 if N
= Last_Statement
then
938 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
940 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
943 -- Retrieve the last statement
945 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
947 -- Check that the last statement is the only possible return
948 -- statement in the subprogram.
950 return Check_All_Returns
(N
) = OK
;
951 end Has_Single_Return_In_GNATprove_Mode
;
953 --------------------------
954 -- Uses_Secondary_Stack --
955 --------------------------
957 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
958 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
959 -- Look for function calls that return an unconstrained type
965 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
967 if Nkind
(N
) = N_Function_Call
968 and then Is_Entity_Name
(Name
(N
))
969 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
970 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
973 ("cannot inline & (call returns unconstrained type)?",
981 function Check_Calls
is new Traverse_Func
(Check_Call
);
984 return Check_Calls
(Bod
) = Abandon
;
985 end Uses_Secondary_Stack
;
987 -- Start of processing for Build_Body_To_Inline
990 -- Return immediately if done already
992 if Nkind
(Decl
) = N_Subprogram_Declaration
993 and then Present
(Body_To_Inline
(Decl
))
997 -- Subprograms that have return statements in the middle of the body are
998 -- inlined with gotos. GNATprove does not currently support gotos, so
999 -- we prevent such inlining.
1001 elsif GNATprove_Mode
1002 and then not Has_Single_Return_In_GNATprove_Mode
1004 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1007 -- Functions that return unconstrained composite types require
1008 -- secondary stack handling, and cannot currently be inlined, unless
1009 -- all return statements return a local variable that is the first
1010 -- local declaration in the body.
1012 elsif Ekind
(Spec_Id
) = E_Function
1013 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1014 and then not Is_Access_Type
(Etype
(Spec_Id
))
1015 and then not Is_Constrained
(Etype
(Spec_Id
))
1017 if not Has_Single_Return
(N
) then
1019 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1023 -- Ditto for functions that return controlled types, where controlled
1024 -- actions interfere in complex ways with inlining.
1026 elsif Ekind
(Spec_Id
) = E_Function
1027 and then Needs_Finalization
(Etype
(Spec_Id
))
1030 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1034 if Present
(Declarations
(N
))
1035 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1040 if Present
(Handled_Statement_Sequence
(N
)) then
1041 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1043 ("cannot inline& (exception handler)?",
1044 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1048 elsif Has_Excluded_Statement
1049 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1055 -- We do not inline a subprogram that is too large, unless it is marked
1056 -- Inline_Always or we are in GNATprove mode. This pragma does not
1057 -- suppress the other checks on inlining (forbidden declarations,
1060 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1061 and then List_Length
1062 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1064 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1068 if Has_Pending_Instantiation
then
1070 ("cannot inline& (forward instance within enclosing body)?",
1075 -- Within an instance, the body to inline must be treated as a nested
1076 -- generic, so that the proper global references are preserved.
1078 -- Note that we do not do this at the library level, because it is not
1079 -- needed, and furthermore this causes trouble if front end inlining
1080 -- is activated (-gnatN).
1082 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1083 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1084 Original_Body
:= Copy_Generic_Node
(N
, Empty
, True);
1086 Original_Body
:= Copy_Separate_Tree
(N
);
1089 -- We need to capture references to the formals in order to substitute
1090 -- the actuals at the point of inlining, i.e. instantiation. To treat
1091 -- the formals as globals to the body to inline, we nest it within a
1092 -- dummy parameterless subprogram, declared within the real one. To
1093 -- avoid generating an internal name (which is never public, and which
1094 -- affects serial numbers of other generated names), we use an internal
1095 -- symbol that cannot conflict with user declarations.
1097 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1098 Set_Defining_Unit_Name
1099 (Specification
(Original_Body
),
1100 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1101 Set_Corresponding_Spec
(Original_Body
, Empty
);
1103 -- Remove those pragmas that have no meaining in an inlined body.
1105 Remove_Pragmas
(Original_Body
);
1107 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1109 -- Set return type of function, which is also global and does not need
1112 if Ekind
(Spec_Id
) = E_Function
then
1113 Set_Result_Definition
(Specification
(Body_To_Analyze
),
1114 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1117 if No
(Declarations
(N
)) then
1118 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1120 Append
(Body_To_Analyze
, Declarations
(N
));
1123 -- The body to inline is pre-analyzed. In GNATprove mode we must
1124 -- disable full analysis as well so that light expansion does not
1125 -- take place either, and name resolution is unaffected.
1127 Expander_Mode_Save_And_Set
(False);
1128 Full_Analysis
:= False;
1130 Analyze
(Body_To_Analyze
);
1131 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1132 Save_Global_References
(Original_Body
);
1134 Remove
(Body_To_Analyze
);
1136 Expander_Mode_Restore
;
1137 Full_Analysis
:= Analysis_Status
;
1139 -- Restore environment if previously saved
1141 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1145 -- If secondary stack is used, there is no point in inlining. We have
1146 -- already issued the warning in this case, so nothing to do.
1148 if Uses_Secondary_Stack
(Body_To_Analyze
) then
1152 Set_Body_To_Inline
(Decl
, Original_Body
);
1153 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1154 Set_Is_Inlined
(Spec_Id
);
1155 end Build_Body_To_Inline
;
1161 procedure Cannot_Inline
1165 Is_Serious
: Boolean := False)
1168 -- In GNATprove mode, inlining is the technical means by which the
1169 -- higher-level goal of contextual analysis is reached, so issue
1170 -- messages about failure to apply contextual analysis to a
1171 -- subprogram, rather than failure to inline it.
1174 and then Msg
(Msg
'First .. Msg
'First + 12) = "cannot inline"
1177 Len1
: constant Positive :=
1178 String (String'("cannot inline"))'Length;
1179 Len2 : constant Positive :=
1180 String (String'("info: no contextual analysis of"))'Length;
1182 New_Msg
: String (1 .. Msg
'Length + Len2
- Len1
);
1185 New_Msg
(1 .. Len2
) := "info: no contextual analysis of";
1186 New_Msg
(Len2
+ 1 .. Msg
'Length + Len2
- Len1
) :=
1187 Msg
(Msg
'First + Len1
.. Msg
'Last);
1188 Cannot_Inline
(New_Msg
, N
, Subp
, Is_Serious
);
1193 pragma Assert
(Msg
(Msg
'Last) = '?');
1195 -- Legacy front end inlining model
1197 if not Back_End_Inlining
then
1199 -- Do not emit warning if this is a predefined unit which is not
1200 -- the main unit. With validity checks enabled, some predefined
1201 -- subprograms may contain nested subprograms and become ineligible
1204 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1205 and then not In_Extended_Main_Source_Unit
(Subp
)
1209 -- In GNATprove mode, issue a warning, and indicate that the
1210 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1213 elsif GNATprove_Mode
then
1214 Set_Is_Inlined_Always
(Subp
, False);
1215 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1217 elsif Has_Pragma_Inline_Always
(Subp
) then
1219 -- Remove last character (question mark) to make this into an
1220 -- error, because the Inline_Always pragma cannot be obeyed.
1222 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1224 elsif Ineffective_Inline_Warnings
then
1225 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1232 elsif Is_Serious
then
1234 -- Remove last character (question mark) to make this into an error.
1236 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1238 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1239 -- is not always inlined by setting flag Is_Inlined_Always to False.
1241 elsif GNATprove_Mode
then
1242 Set_Is_Inlined_Always
(Subp
, False);
1243 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1245 -- Do not issue errors/warnings when compiling with optimizations
1247 elsif Optimization_Level
= 0 then
1249 -- Do not emit warning if this is a predefined unit which is not
1250 -- the main unit. This behavior is currently provided for backward
1251 -- compatibility but it will be removed when we enforce the
1252 -- strictness of the new rules.
1254 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1255 and then not In_Extended_Main_Source_Unit
(Subp
)
1259 elsif Has_Pragma_Inline_Always
(Subp
) then
1261 -- Emit a warning if this is a call to a runtime subprogram
1262 -- which is located inside a generic. Previously this call
1263 -- was silently skipped.
1265 if Is_Generic_Instance
(Subp
) then
1267 Gen_P
: constant Entity_Id
:= Generic_Parent
(Parent
(Subp
));
1269 if Is_Predefined_File_Name
1270 (Unit_File_Name
(Get_Source_Unit
(Gen_P
)))
1272 Set_Is_Inlined
(Subp
, False);
1273 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1279 -- Remove last character (question mark) to make this into an
1280 -- error, because the Inline_Always pragma cannot be obeyed.
1282 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1284 else pragma Assert
(Front_End_Inlining
);
1285 Set_Is_Inlined
(Subp
, False);
1287 -- When inlining cannot take place we must issue an error.
1288 -- For backward compatibility we still report a warning.
1290 if Ineffective_Inline_Warnings
then
1291 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1295 -- Compiling with optimizations enabled it is too early to report
1296 -- problems since the backend may still perform inlining. In order
1297 -- to report unhandled inlinings the program must be compiled with
1298 -- -Winline and the error is reported by the backend.
1305 --------------------------------------
1306 -- Can_Be_Inlined_In_GNATprove_Mode --
1307 --------------------------------------
1309 function Can_Be_Inlined_In_GNATprove_Mode
1310 (Spec_Id
: Entity_Id
;
1311 Body_Id
: Entity_Id
) return Boolean
1313 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1314 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1317 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1318 -- Returns True if subprogram Id defines a compilation unit
1319 -- Shouldn't this be in Sem_Aux???
1321 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean;
1322 -- Returns True if subprogram Id is defined in the visible part of a
1323 -- package specification.
1325 function Is_Expression_Function
(Id
: Entity_Id
) return Boolean;
1326 -- Returns True if subprogram Id was defined originally as an expression
1329 -----------------------
1330 -- Has_Some_Contract --
1331 -----------------------
1333 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean is
1334 Items
: constant Node_Id
:= Contract
(Id
);
1336 return Present
(Items
)
1337 and then (Present
(Pre_Post_Conditions
(Items
)) or else
1338 Present
(Contract_Test_Cases
(Items
)) or else
1339 Present
(Classifications
(Items
)));
1340 end Has_Some_Contract
;
1342 -----------------------------
1343 -- In_Package_Visible_Spec --
1344 -----------------------------
1346 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean is
1347 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1351 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1352 Decl
:= Parent
(Decl
);
1357 return Nkind
(P
) = N_Package_Specification
1358 and then List_Containing
(Decl
) = Visible_Declarations
(P
);
1359 end In_Package_Visible_Spec
;
1361 ----------------------------
1362 -- Is_Expression_Function --
1363 ----------------------------
1365 function Is_Expression_Function
(Id
: Entity_Id
) return Boolean is
1366 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1368 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1369 Decl
:= Parent
(Decl
);
1372 return Nkind
(Original_Node
(Decl
)) = N_Expression_Function
;
1373 end Is_Expression_Function
;
1375 ------------------------
1376 -- Is_Unit_Subprogram --
1377 ------------------------
1379 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean is
1380 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1382 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1383 Decl
:= Parent
(Decl
);
1386 return Nkind
(Parent
(Decl
)) = N_Compilation_Unit
;
1387 end Is_Unit_Subprogram
;
1389 -- Local declarations
1391 Id
: Entity_Id
; -- Procedure or function entity for the subprogram
1393 -- Start of Can_Be_Inlined_In_GNATprove_Mode
1396 pragma Assert
(Present
(Spec_Id
) or else Present
(Body_Id
));
1398 if Present
(Spec_Id
) then
1404 -- Only local subprograms without contracts are inlined in GNATprove
1405 -- mode, as these are the subprograms which a user is not interested in
1406 -- analyzing in isolation, but rather in the context of their call. This
1407 -- is a convenient convention, that could be changed for an explicit
1408 -- pragma/aspect one day.
1410 -- In a number of special cases, inlining is not desirable or not
1411 -- possible, see below.
1413 -- Do not inline unit-level subprograms
1415 if Is_Unit_Subprogram
(Id
) then
1418 -- Do not inline subprograms declared in the visible part of a package
1420 elsif In_Package_Visible_Spec
(Id
) then
1423 -- Do not inline subprograms that have a contract on the spec or the
1424 -- body. Use the contract(s) instead in GNATprove.
1426 elsif (Present
(Spec_Id
) and then Has_Some_Contract
(Spec_Id
))
1428 (Present
(Body_Id
) and then Has_Some_Contract
(Body_Id
))
1432 -- Do not inline expression functions, which are directly inlined at the
1435 elsif (Present
(Spec_Id
) and then Is_Expression_Function
(Spec_Id
))
1437 (Present
(Body_Id
) and then Is_Expression_Function
(Body_Id
))
1441 -- Do not inline generic subprogram instances. The visibility rules of
1442 -- generic instances plays badly with inlining.
1444 elsif Is_Generic_Instance
(Spec_Id
) then
1447 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1448 -- the subprogram body, a similar check is performed after the body
1449 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1451 elsif Present
(Spec_Id
)
1453 (No
(SPARK_Pragma
(Spec_Id
))
1454 or else Get_SPARK_Mode_From_Pragma
(SPARK_Pragma
(Spec_Id
)) /= On
)
1458 -- Subprograms in generic instances are currently not inlined, to avoid
1459 -- problems with inlining of standard library subprograms.
1461 elsif Instantiation_Location
(Sloc
(Id
)) /= No_Location
then
1464 -- Don't inline predicate functions (treated specially by GNATprove)
1466 elsif Is_Predicate_Function
(Id
) then
1469 -- Otherwise, this is a subprogram declared inside the private part of a
1470 -- package, or inside a package body, or locally in a subprogram, and it
1471 -- does not have any contract. Inline it.
1476 end Can_Be_Inlined_In_GNATprove_Mode
;
1478 --------------------------------------------
1479 -- Check_And_Split_Unconstrained_Function --
1480 --------------------------------------------
1482 procedure Check_And_Split_Unconstrained_Function
1484 Spec_Id
: Entity_Id
;
1485 Body_Id
: Entity_Id
)
1487 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
);
1488 -- Use generic machinery to build an unexpanded body for the subprogram.
1489 -- This body is subsequently used for inline expansions at call sites.
1491 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean;
1492 -- Return true if we generate code for the function body N, the function
1493 -- body N has no local declarations and its unique statement is a single
1494 -- extended return statement with a handled statements sequence.
1496 procedure Generate_Subprogram_Body
1498 Body_To_Inline
: out Node_Id
);
1499 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1500 -- of pragmas referencing the formals are removed since they have no
1501 -- meaning when the body is inlined and the formals are rewritten (the
1502 -- analysis of the non-inlined body will handle these pragmas properly).
1503 -- A new internal name is associated with Body_To_Inline.
1505 procedure Split_Unconstrained_Function
1507 Spec_Id
: Entity_Id
);
1508 -- N is an inlined function body that returns an unconstrained type and
1509 -- has a single extended return statement. Split N in two subprograms:
1510 -- a procedure P' and a function F'. The formals of P' duplicate the
1511 -- formals of N plus an extra formal which is used return a value;
1512 -- its body is composed by the declarations and list of statements
1513 -- of the extended return statement of N.
1515 --------------------------
1516 -- Build_Body_To_Inline --
1517 --------------------------
1519 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1520 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1521 Original_Body
: Node_Id
;
1522 Body_To_Analyze
: Node_Id
;
1525 pragma Assert
(Current_Scope
= Spec_Id
);
1527 -- Within an instance, the body to inline must be treated as a nested
1528 -- generic, so that the proper global references are preserved. We
1529 -- do not do this at the library level, because it is not needed, and
1530 -- furthermore this causes trouble if front end inlining is activated
1534 and then Scope
(Current_Scope
) /= Standard_Standard
1536 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1539 -- We need to capture references to the formals in order
1540 -- to substitute the actuals at the point of inlining, i.e.
1541 -- instantiation. To treat the formals as globals to the body to
1542 -- inline, we nest it within a dummy parameterless subprogram,
1543 -- declared within the real one.
1545 Generate_Subprogram_Body
(N
, Original_Body
);
1546 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1548 -- Set return type of function, which is also global and does not
1549 -- need to be resolved.
1551 if Ekind
(Spec_Id
) = E_Function
then
1552 Set_Result_Definition
(Specification
(Body_To_Analyze
),
1553 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1556 if No
(Declarations
(N
)) then
1557 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1559 Append_To
(Declarations
(N
), Body_To_Analyze
);
1562 Preanalyze
(Body_To_Analyze
);
1564 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1565 Save_Global_References
(Original_Body
);
1567 Remove
(Body_To_Analyze
);
1569 -- Restore environment if previously saved
1572 and then Scope
(Current_Scope
) /= Standard_Standard
1577 pragma Assert
(No
(Body_To_Inline
(Decl
)));
1578 Set_Body_To_Inline
(Decl
, Original_Body
);
1579 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1580 end Build_Body_To_Inline
;
1582 --------------------------------------
1583 -- Can_Split_Unconstrained_Function --
1584 --------------------------------------
1586 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean
1588 Ret_Node
: constant Node_Id
:=
1589 First
(Statements
(Handled_Statement_Sequence
(N
)));
1593 -- No user defined declarations allowed in the function except inside
1594 -- the unique return statement; implicit labels are the only allowed
1597 if not Is_Empty_List
(Declarations
(N
)) then
1598 D
:= First
(Declarations
(N
));
1599 while Present
(D
) loop
1600 if Nkind
(D
) /= N_Implicit_Label_Declaration
then
1608 -- We only split the inlined function when we are generating the code
1609 -- of its body; otherwise we leave duplicated split subprograms in
1610 -- the tree which (if referenced) generate wrong references at link
1613 return In_Extended_Main_Code_Unit
(N
)
1614 and then Present
(Ret_Node
)
1615 and then Nkind
(Ret_Node
) = N_Extended_Return_Statement
1616 and then No
(Next
(Ret_Node
))
1617 and then Present
(Handled_Statement_Sequence
(Ret_Node
));
1618 end Can_Split_Unconstrained_Function
;
1620 -----------------------------
1621 -- Generate_Body_To_Inline --
1622 -----------------------------
1624 procedure Generate_Subprogram_Body
1626 Body_To_Inline
: out Node_Id
)
1629 -- Within an instance, the body to inline must be treated as a nested
1630 -- generic, so that the proper global references are preserved.
1632 -- Note that we do not do this at the library level, because it
1633 -- is not needed, and furthermore this causes trouble if front
1634 -- end inlining is activated (-gnatN).
1637 and then Scope
(Current_Scope
) /= Standard_Standard
1639 Body_To_Inline
:= Copy_Generic_Node
(N
, Empty
, True);
1641 Body_To_Inline
:= Copy_Separate_Tree
(N
);
1644 -- A pragma Unreferenced or pragma Unmodified that mentions a formal
1645 -- parameter has no meaning when the body is inlined and the formals
1646 -- are rewritten. Remove it from body to inline. The analysis of the
1647 -- non-inlined body will handle the pragma properly.
1649 Remove_Pragmas
(Body_To_Inline
);
1651 -- We need to capture references to the formals in order
1652 -- to substitute the actuals at the point of inlining, i.e.
1653 -- instantiation. To treat the formals as globals to the body to
1654 -- inline, we nest it within a dummy parameterless subprogram,
1655 -- declared within the real one.
1657 Set_Parameter_Specifications
1658 (Specification
(Body_To_Inline
), No_List
);
1660 -- A new internal name is associated with Body_To_Inline to avoid
1661 -- conflicts when the non-inlined body N is analyzed.
1663 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
1664 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
1665 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
1666 end Generate_Subprogram_Body
;
1668 ----------------------------------
1669 -- Split_Unconstrained_Function --
1670 ----------------------------------
1672 procedure Split_Unconstrained_Function
1674 Spec_Id
: Entity_Id
)
1676 Loc
: constant Source_Ptr
:= Sloc
(N
);
1677 Ret_Node
: constant Node_Id
:=
1678 First
(Statements
(Handled_Statement_Sequence
(N
)));
1679 Ret_Obj
: constant Node_Id
:=
1680 First
(Return_Object_Declarations
(Ret_Node
));
1682 procedure Build_Procedure
1683 (Proc_Id
: out Entity_Id
;
1684 Decl_List
: out List_Id
);
1685 -- Build a procedure containing the statements found in the extended
1686 -- return statement of the unconstrained function body N.
1688 ---------------------
1689 -- Build_Procedure --
1690 ---------------------
1692 procedure Build_Procedure
1693 (Proc_Id
: out Entity_Id
;
1694 Decl_List
: out List_Id
)
1697 Formal_List
: constant List_Id
:= New_List
;
1698 Proc_Spec
: Node_Id
;
1699 Proc_Body
: Node_Id
;
1700 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
1701 Body_Decl_List
: List_Id
:= No_List
;
1702 Param_Type
: Node_Id
;
1705 if Nkind
(Object_Definition
(Ret_Obj
)) = N_Identifier
then
1707 New_Copy
(Object_Definition
(Ret_Obj
));
1710 New_Copy
(Subtype_Mark
(Object_Definition
(Ret_Obj
)));
1713 Append_To
(Formal_List
,
1714 Make_Parameter_Specification
(Loc
,
1715 Defining_Identifier
=>
1716 Make_Defining_Identifier
(Loc
,
1717 Chars
=> Chars
(Defining_Identifier
(Ret_Obj
))),
1718 In_Present
=> False,
1719 Out_Present
=> True,
1720 Null_Exclusion_Present
=> False,
1721 Parameter_Type
=> Param_Type
));
1723 Formal
:= First_Formal
(Spec_Id
);
1724 while Present
(Formal
) loop
1725 Append_To
(Formal_List
,
1726 Make_Parameter_Specification
(Loc
,
1727 Defining_Identifier
=>
1728 Make_Defining_Identifier
(Sloc
(Formal
),
1729 Chars
=> Chars
(Formal
)),
1730 In_Present
=> In_Present
(Parent
(Formal
)),
1731 Out_Present
=> Out_Present
(Parent
(Formal
)),
1732 Null_Exclusion_Present
=>
1733 Null_Exclusion_Present
(Parent
(Formal
)),
1735 New_Occurrence_Of
(Etype
(Formal
), Loc
),
1737 Copy_Separate_Tree
(Expression
(Parent
(Formal
)))));
1739 Next_Formal
(Formal
);
1742 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
1745 Make_Procedure_Specification
(Loc
,
1746 Defining_Unit_Name
=> Proc_Id
,
1747 Parameter_Specifications
=> Formal_List
);
1749 Decl_List
:= New_List
;
1751 Append_To
(Decl_List
,
1752 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
1754 -- Can_Convert_Unconstrained_Function checked that the function
1755 -- has no local declarations except implicit label declarations.
1756 -- Copy these declarations to the built procedure.
1758 if Present
(Declarations
(N
)) then
1759 Body_Decl_List
:= New_List
;
1766 D
:= First
(Declarations
(N
));
1767 while Present
(D
) loop
1768 pragma Assert
(Nkind
(D
) = N_Implicit_Label_Declaration
);
1771 Make_Implicit_Label_Declaration
(Loc
,
1772 Make_Defining_Identifier
(Loc
,
1773 Chars
=> Chars
(Defining_Identifier
(D
))),
1774 Label_Construct
=> Empty
);
1775 Append_To
(Body_Decl_List
, New_D
);
1782 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Node
)));
1785 Make_Subprogram_Body
(Loc
,
1786 Specification
=> Copy_Separate_Tree
(Proc_Spec
),
1787 Declarations
=> Body_Decl_List
,
1788 Handled_Statement_Sequence
=>
1789 Copy_Separate_Tree
(Handled_Statement_Sequence
(Ret_Node
)));
1791 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
1792 Make_Defining_Identifier
(Loc
, Subp_Name
));
1794 Append_To
(Decl_List
, Proc_Body
);
1795 end Build_Procedure
;
1799 New_Obj
: constant Node_Id
:= Copy_Separate_Tree
(Ret_Obj
);
1801 Proc_Id
: Entity_Id
;
1802 Proc_Call
: Node_Id
;
1804 -- Start of processing for Split_Unconstrained_Function
1807 -- Build the associated procedure, analyze it and insert it before
1808 -- the function body N.
1811 Scope
: constant Entity_Id
:= Current_Scope
;
1812 Decl_List
: List_Id
;
1815 Build_Procedure
(Proc_Id
, Decl_List
);
1816 Insert_Actions
(N
, Decl_List
);
1820 -- Build the call to the generated procedure
1823 Actual_List
: constant List_Id
:= New_List
;
1827 Append_To
(Actual_List
,
1828 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
1830 Formal
:= First_Formal
(Spec_Id
);
1831 while Present
(Formal
) loop
1832 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
1834 -- Avoid spurious warning on unreferenced formals
1836 Set_Referenced
(Formal
);
1837 Next_Formal
(Formal
);
1841 Make_Procedure_Call_Statement
(Loc
,
1842 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
1843 Parameter_Associations
=> Actual_List
);
1851 -- main_1__F1b (New_Obj, ...);
1856 Make_Block_Statement
(Loc
,
1857 Declarations
=> New_List
(New_Obj
),
1858 Handled_Statement_Sequence
=>
1859 Make_Handled_Sequence_Of_Statements
(Loc
,
1860 Statements
=> New_List
(
1864 Make_Simple_Return_Statement
(Loc
,
1867 (Defining_Identifier
(New_Obj
), Loc
)))));
1869 Rewrite
(Ret_Node
, Blk_Stmt
);
1870 end Split_Unconstrained_Function
;
1874 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1876 -- Start of processing for Check_And_Split_Unconstrained_Function
1879 pragma Assert
(Back_End_Inlining
1880 and then Ekind
(Spec_Id
) = E_Function
1881 and then Returns_Unconstrained_Type
(Spec_Id
)
1882 and then Comes_From_Source
(Body_Id
)
1883 and then (Has_Pragma_Inline_Always
(Spec_Id
)
1884 or else Optimization_Level
> 0));
1886 -- This routine must not be used in GNATprove mode since GNATprove
1887 -- relies on frontend inlining
1889 pragma Assert
(not GNATprove_Mode
);
1891 -- No need to split the function if we cannot generate the code
1893 if Serious_Errors_Detected
/= 0 then
1897 -- Do not inline any subprogram that contains nested subprograms,
1898 -- since the backend inlining circuit seems to generate uninitialized
1899 -- references in this case. We know this happens in the case of front
1900 -- end ZCX support, but it also appears it can happen in other cases
1901 -- as well. The backend often rejects attempts to inline in the case
1902 -- of nested procedures anyway, so little if anything is lost by this.
1903 -- Note that this is test is for the benefit of the back-end. There
1904 -- is a separate test for front-end inlining that also rejects nested
1907 -- Do not do this test if errors have been detected, because in some
1908 -- error cases, this code blows up, and we don't need it anyway if
1909 -- there have been errors, since we won't get to the linker anyway.
1917 P_Ent
:= Scope
(P_Ent
);
1918 exit when No
(P_Ent
) or else P_Ent
= Standard_Standard
;
1920 if Is_Subprogram
(P_Ent
) then
1921 Set_Is_Inlined
(P_Ent
, False);
1923 if Comes_From_Source
(P_Ent
)
1924 and then (Has_Pragma_Inline
(P_Ent
))
1927 ("cannot inline& (nested subprogram)?", N
, P_Ent
,
1928 Is_Serious
=> True);
1935 -- No action needed in stubs since the attribute Body_To_Inline
1938 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
1941 -- Cannot build the body to inline if the attribute is already set.
1942 -- This attribute may have been set if this is a subprogram renaming
1943 -- declarations (see Freeze.Build_Renamed_Body).
1945 elsif Present
(Body_To_Inline
(Decl
)) then
1948 -- Check excluded declarations
1950 elsif Present
(Declarations
(N
))
1951 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1955 -- Check excluded statements. There is no need to protect us against
1956 -- exception handlers since they are supported by the GCC backend.
1958 elsif Present
(Handled_Statement_Sequence
(N
))
1959 and then Has_Excluded_Statement
1960 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1965 -- Build the body to inline only if really needed
1967 if Can_Split_Unconstrained_Function
(N
) then
1968 Split_Unconstrained_Function
(N
, Spec_Id
);
1969 Build_Body_To_Inline
(N
, Spec_Id
);
1970 Set_Is_Inlined
(Spec_Id
);
1972 end Check_And_Split_Unconstrained_Function
;
1974 -------------------------------------
1975 -- Check_Package_Body_For_Inlining --
1976 -------------------------------------
1978 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
1979 Bname
: Unit_Name_Type
;
1984 if Front_End_Inlining
1985 and then Is_Compilation_Unit
(P
)
1986 and then not Is_Generic_Instance
(P
)
1988 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
1990 E
:= First_Entity
(P
);
1991 while Present
(E
) loop
1992 if Has_Pragma_Inline
(E
) then
1993 if not Is_Loaded
(Bname
) then
1994 Load_Needed_Body
(N
, OK
);
1998 -- Check we are not trying to inline a parent whose body
1999 -- depends on a child, when we are compiling the body of
2000 -- the child. Otherwise we have a potential elaboration
2001 -- circularity with inlined subprograms and with
2002 -- Taft-Amendment types.
2005 Comp
: Node_Id
; -- Body just compiled
2006 Child_Spec
: Entity_Id
; -- Spec of main unit
2007 Ent
: Entity_Id
; -- For iteration
2008 With_Clause
: Node_Id
; -- Context of body.
2011 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2012 and then Present
(Body_Entity
(P
))
2016 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2019 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2021 -- Check whether the context of the body just
2022 -- compiled includes a child of itself, and that
2023 -- child is the spec of the main compilation.
2025 With_Clause
:= First
(Context_Items
(Comp
));
2026 while Present
(With_Clause
) loop
2027 if Nkind
(With_Clause
) = N_With_Clause
2029 Scope
(Entity
(Name
(With_Clause
))) = P
2031 Entity
(Name
(With_Clause
)) = Child_Spec
2033 Error_Msg_Node_2
:= Child_Spec
;
2035 ("body of & depends on child unit&??",
2038 ("\subprograms in body cannot be inlined??",
2041 -- Disable further inlining from this unit,
2042 -- and keep Taft-amendment types incomplete.
2044 Ent
:= First_Entity
(P
);
2045 while Present
(Ent
) loop
2047 and then Has_Completion_In_Body
(Ent
)
2049 Set_Full_View
(Ent
, Empty
);
2051 elsif Is_Subprogram
(Ent
) then
2052 Set_Is_Inlined
(Ent
, False);
2066 elsif Ineffective_Inline_Warnings
then
2067 Error_Msg_Unit_1
:= Bname
;
2069 ("unable to inline subprograms defined in $??", P
);
2070 Error_Msg_N
("\body not found??", P
);
2081 end Check_Package_Body_For_Inlining
;
2083 --------------------
2084 -- Cleanup_Scopes --
2085 --------------------
2087 procedure Cleanup_Scopes
is
2093 Elmt
:= First_Elmt
(To_Clean
);
2094 while Present
(Elmt
) loop
2095 Scop
:= Node
(Elmt
);
2097 if Ekind
(Scop
) = E_Entry
then
2098 Scop
:= Protected_Body_Subprogram
(Scop
);
2100 elsif Is_Subprogram
(Scop
)
2101 and then Is_Protected_Type
(Scope
(Scop
))
2102 and then Present
(Protected_Body_Subprogram
(Scop
))
2104 -- If a protected operation contains an instance, its cleanup
2105 -- operations have been delayed, and the subprogram has been
2106 -- rewritten in the expansion of the enclosing protected body. It
2107 -- is the corresponding subprogram that may require the cleanup
2108 -- operations, so propagate the information that triggers cleanup
2112 (Protected_Body_Subprogram
(Scop
),
2113 Uses_Sec_Stack
(Scop
));
2115 Scop
:= Protected_Body_Subprogram
(Scop
);
2118 if Ekind
(Scop
) = E_Block
then
2119 Decl
:= Parent
(Block_Node
(Scop
));
2122 Decl
:= Unit_Declaration_Node
(Scop
);
2124 if Nkind_In
(Decl
, N_Subprogram_Declaration
,
2125 N_Task_Type_Declaration
,
2126 N_Subprogram_Body_Stub
)
2128 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2133 Expand_Cleanup_Actions
(Decl
);
2136 Elmt
:= Next_Elmt
(Elmt
);
2140 -------------------------
2141 -- Expand_Inlined_Call --
2142 -------------------------
2144 procedure Expand_Inlined_Call
2147 Orig_Subp
: Entity_Id
)
2149 Loc
: constant Source_Ptr
:= Sloc
(N
);
2150 Is_Predef
: constant Boolean :=
2151 Is_Predefined_File_Name
2152 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2153 Orig_Bod
: constant Node_Id
:=
2154 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2158 Decls
: constant List_Id
:= New_List
;
2159 Exit_Lab
: Entity_Id
:= Empty
;
2166 Ret_Type
: Entity_Id
;
2169 -- The target of the call. If context is an assignment statement then
2170 -- this is the left-hand side of the assignment, else it is a temporary
2171 -- to which the return value is assigned prior to rewriting the call.
2174 -- A separate target used when the return type is unconstrained
2177 Temp_Typ
: Entity_Id
;
2179 Return_Object
: Entity_Id
:= Empty
;
2180 -- Entity in declaration in an extended_return_statement
2183 Is_Unc_Decl
: Boolean;
2184 -- If the type returned by the function is unconstrained and the call
2185 -- can be inlined, special processing is required.
2187 procedure Make_Exit_Label
;
2188 -- Build declaration for exit label to be used in Return statements,
2189 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2190 -- declaration). Does nothing if Exit_Lab already set.
2192 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2193 -- Replace occurrence of a formal with the corresponding actual, or the
2194 -- thunk generated for it. Replace a return statement with an assignment
2195 -- to the target of the call, with appropriate conversions if needed.
2197 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2198 -- If the call being expanded is that of an internal subprogram, set the
2199 -- sloc of the generated block to that of the call itself, so that the
2200 -- expansion is skipped by the "next" command in gdb. Same processing
2201 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2202 -- Debug_Generated_Code is true, suppress this change to simplify our
2203 -- own development. Same in GNATprove mode, to ensure that warnings and
2204 -- diagnostics point to the proper location.
2206 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
2207 -- In subtree N search for occurrences of dispatching calls that use the
2208 -- Ada 2005 Object.Operation notation and the object is a formal of the
2209 -- inlined subprogram. Reset the entity associated with Operation in all
2210 -- the found occurrences.
2212 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2213 -- If the function body is a single expression, replace call with
2214 -- expression, else insert block appropriately.
2216 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2217 -- If procedure body has no local variables, inline body without
2218 -- creating block, otherwise rewrite call with block.
2220 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2221 -- Determine whether a formal parameter is used only once in Orig_Bod
2223 ---------------------
2224 -- Make_Exit_Label --
2225 ---------------------
2227 procedure Make_Exit_Label
is
2228 Lab_Ent
: Entity_Id
;
2230 if No
(Exit_Lab
) then
2231 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
2232 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
2233 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2235 Make_Implicit_Label_Declaration
(Loc
,
2236 Defining_Identifier
=> Lab_Ent
,
2237 Label_Construct
=> Exit_Lab
);
2239 end Make_Exit_Label
;
2241 ---------------------
2242 -- Process_Formals --
2243 ---------------------
2245 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2251 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
2254 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
2255 A
:= Renamed_Object
(E
);
2257 -- Rewrite the occurrence of the formal into an occurrence of
2258 -- the actual. Also establish visibility on the proper view of
2259 -- the actual's subtype for the body's context (if the actual's
2260 -- subtype is private at the call point but its full view is
2261 -- visible to the body, then the inlined tree here must be
2262 -- analyzed with the full view).
2264 if Is_Entity_Name
(A
) then
2265 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Loc
));
2266 Check_Private_View
(N
);
2268 elsif Nkind
(A
) = N_Defining_Identifier
then
2269 Rewrite
(N
, New_Occurrence_Of
(A
, Loc
));
2270 Check_Private_View
(N
);
2275 Rewrite
(N
, New_Copy
(A
));
2281 elsif Is_Entity_Name
(N
)
2282 and then Present
(Return_Object
)
2283 and then Chars
(N
) = Chars
(Return_Object
)
2285 -- Occurrence within an extended return statement. The return
2286 -- object is local to the body been inlined, and thus the generic
2287 -- copy is not analyzed yet, so we match by name, and replace it
2288 -- with target of call.
2290 if Nkind
(Targ
) = N_Defining_Identifier
then
2291 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
2293 Rewrite
(N
, New_Copy_Tree
(Targ
));
2298 elsif Nkind
(N
) = N_Simple_Return_Statement
then
2299 if No
(Expression
(N
)) then
2302 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2305 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2306 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2308 -- Function body is a single expression. No need for
2314 Num_Ret
:= Num_Ret
+ 1;
2318 -- Because of the presence of private types, the views of the
2319 -- expression and the context may be different, so place an
2320 -- unchecked conversion to the context type to avoid spurious
2321 -- errors, e.g. when the expression is a numeric literal and
2322 -- the context is private. If the expression is an aggregate,
2323 -- use a qualified expression, because an aggregate is not a
2324 -- legal argument of a conversion. Ditto for numeric literals,
2325 -- which must be resolved to a specific type.
2327 if Nkind_In
(Expression
(N
), N_Aggregate
,
2333 Make_Qualified_Expression
(Sloc
(N
),
2334 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2335 Expression
=> Relocate_Node
(Expression
(N
)));
2338 Unchecked_Convert_To
2339 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2342 if Nkind
(Targ
) = N_Defining_Identifier
then
2344 Make_Assignment_Statement
(Loc
,
2345 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2346 Expression
=> Ret
));
2349 Make_Assignment_Statement
(Loc
,
2350 Name
=> New_Copy
(Targ
),
2351 Expression
=> Ret
));
2354 Set_Assignment_OK
(Name
(N
));
2356 if Present
(Exit_Lab
) then
2358 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2364 -- An extended return becomes a block whose first statement is the
2365 -- assignment of the initial expression of the return object to the
2366 -- target of the call itself.
2368 elsif Nkind
(N
) = N_Extended_Return_Statement
then
2370 Return_Decl
: constant Entity_Id
:=
2371 First
(Return_Object_Declarations
(N
));
2375 Return_Object
:= Defining_Identifier
(Return_Decl
);
2377 if Present
(Expression
(Return_Decl
)) then
2378 if Nkind
(Targ
) = N_Defining_Identifier
then
2380 Make_Assignment_Statement
(Loc
,
2381 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2382 Expression
=> Expression
(Return_Decl
));
2385 Make_Assignment_Statement
(Loc
,
2386 Name
=> New_Copy
(Targ
),
2387 Expression
=> Expression
(Return_Decl
));
2390 Set_Assignment_OK
(Name
(Assign
));
2392 if No
(Handled_Statement_Sequence
(N
)) then
2393 Set_Handled_Statement_Sequence
(N
,
2394 Make_Handled_Sequence_Of_Statements
(Loc
,
2395 Statements
=> New_List
));
2399 Statements
(Handled_Statement_Sequence
(N
)));
2403 Make_Block_Statement
(Loc
,
2404 Handled_Statement_Sequence
=>
2405 Handled_Statement_Sequence
(N
)));
2410 -- Remove pragma Unreferenced since it may refer to formals that
2411 -- are not visible in the inlined body, and in any case we will
2412 -- not be posting warnings on the inlined body so it is unneeded.
2414 elsif Nkind
(N
) = N_Pragma
2415 and then Pragma_Name
(N
) = Name_Unreferenced
2417 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2423 end Process_Formals
;
2425 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2431 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2433 if not Debug_Generated_Code
then
2434 Set_Sloc
(Nod
, Sloc
(N
));
2435 Set_Comes_From_Source
(Nod
, False);
2441 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2443 ------------------------------
2444 -- Reset_Dispatching_Calls --
2445 ------------------------------
2447 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
2449 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
2450 -- Comment required ???
2456 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
2458 if Nkind
(N
) = N_Procedure_Call_Statement
2459 and then Nkind
(Name
(N
)) = N_Selected_Component
2460 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
2461 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
2462 and then Is_Dispatching_Operation
2463 (Entity
(Selector_Name
(Name
(N
))))
2465 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
2471 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
2475 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
2476 pragma Unreferenced
(Dummy
);
2478 -- Start of processing for Reset_Dispatching_Calls
2482 end Reset_Dispatching_Calls
;
2484 ---------------------------
2485 -- Rewrite_Function_Call --
2486 ---------------------------
2488 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2489 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2490 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2493 -- Optimize simple case: function body is a single return statement,
2494 -- which has been expanded into an assignment.
2496 if Is_Empty_List
(Declarations
(Blk
))
2497 and then Nkind
(Fst
) = N_Assignment_Statement
2498 and then No
(Next
(Fst
))
2500 -- The function call may have been rewritten as the temporary
2501 -- that holds the result of the call, in which case remove the
2502 -- now useless declaration.
2504 if Nkind
(N
) = N_Identifier
2505 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2507 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2510 Rewrite
(N
, Expression
(Fst
));
2512 elsif Nkind
(N
) = N_Identifier
2513 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2515 -- The block assigns the result of the call to the temporary
2517 Insert_After
(Parent
(Entity
(N
)), Blk
);
2519 -- If the context is an assignment, and the left-hand side is free of
2520 -- side-effects, the replacement is also safe.
2521 -- Can this be generalized further???
2523 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2525 (Is_Entity_Name
(Name
(Parent
(N
)))
2527 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
2528 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
2531 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2532 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
2534 -- Replace assignment with the block
2537 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2540 -- Preserve the original assignment node to keep the complete
2541 -- assignment subtree consistent enough for Analyze_Assignment
2542 -- to proceed (specifically, the original Lhs node must still
2543 -- have an assignment statement as its parent).
2545 -- We cannot rely on Original_Node to go back from the block
2546 -- node to the assignment node, because the assignment might
2547 -- already be a rewrite substitution.
2549 Discard_Node
(Relocate_Node
(Original_Assignment
));
2550 Rewrite
(Original_Assignment
, Blk
);
2553 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2555 -- A call to a function which returns an unconstrained type
2556 -- found in the expression initializing an object-declaration is
2557 -- expanded into a procedure call which must be added after the
2558 -- object declaration.
2560 if Is_Unc_Decl
and Back_End_Inlining
then
2561 Insert_Action_After
(Parent
(N
), Blk
);
2563 Set_Expression
(Parent
(N
), Empty
);
2564 Insert_After
(Parent
(N
), Blk
);
2567 elsif Is_Unc
and then not Back_End_Inlining
then
2568 Insert_Before
(Parent
(N
), Blk
);
2570 end Rewrite_Function_Call
;
2572 ----------------------------
2573 -- Rewrite_Procedure_Call --
2574 ----------------------------
2576 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2577 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2580 -- If there is a transient scope for N, this will be the scope of the
2581 -- actions for N, and the statements in Blk need to be within this
2582 -- scope. For example, they need to have visibility on the constant
2583 -- declarations created for the formals.
2585 -- If N needs no transient scope, and if there are no declarations in
2586 -- the inlined body, we can do a little optimization and insert the
2587 -- statements for the body directly after N, and rewrite N to a
2588 -- null statement, instead of rewriting N into a full-blown block
2591 if not Scope_Is_Transient
2592 and then Is_Empty_List
(Declarations
(Blk
))
2594 Insert_List_After
(N
, Statements
(HSS
));
2595 Rewrite
(N
, Make_Null_Statement
(Loc
));
2599 end Rewrite_Procedure_Call
;
2601 -------------------------
2602 -- Formal_Is_Used_Once --
2603 -------------------------
2605 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2606 Use_Counter
: Int
:= 0;
2608 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2609 -- Traverse the tree and count the uses of the formal parameter.
2610 -- In this case, for optimization purposes, we do not need to
2611 -- continue the traversal once more than one use is encountered.
2617 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2619 -- The original node is an identifier
2621 if Nkind
(N
) = N_Identifier
2622 and then Present
(Entity
(N
))
2624 -- Original node's entity points to the one in the copied body
2626 and then Nkind
(Entity
(N
)) = N_Identifier
2627 and then Present
(Entity
(Entity
(N
)))
2629 -- The entity of the copied node is the formal parameter
2631 and then Entity
(Entity
(N
)) = Formal
2633 Use_Counter
:= Use_Counter
+ 1;
2635 if Use_Counter
> 1 then
2637 -- Denote more than one use and abandon the traversal
2648 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2650 -- Start of processing for Formal_Is_Used_Once
2653 Count_Formal_Uses
(Orig_Bod
);
2654 return Use_Counter
= 1;
2655 end Formal_Is_Used_Once
;
2657 -- Start of processing for Expand_Inlined_Call
2660 -- Initializations for old/new semantics
2662 if not Back_End_Inlining
then
2663 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
2664 and then not Is_Constrained
(Etype
(Subp
));
2665 Is_Unc_Decl
:= False;
2667 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
2668 and then Optimization_Level
> 0;
2669 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
2673 -- Check for an illegal attempt to inline a recursive procedure. If the
2674 -- subprogram has parameters this is detected when trying to supply a
2675 -- binding for parameters that already have one. For parameterless
2676 -- subprograms this must be done explicitly.
2678 if In_Open_Scopes
(Subp
) then
2679 Error_Msg_N
("call to recursive subprogram cannot be inlined??", N
);
2680 Set_Is_Inlined
(Subp
, False);
2682 -- In GNATprove mode, issue a warning, and indicate that the
2683 -- subprogram is not always inlined by setting flag Is_Inlined_Always
2686 if GNATprove_Mode
then
2687 Set_Is_Inlined_Always
(Subp
, False);
2692 -- Skip inlining if this is not a true inlining since the attribute
2693 -- Body_To_Inline is also set for renamings (see sinfo.ads)
2695 elsif Nkind
(Orig_Bod
) in N_Entity
then
2698 -- Skip inlining if the function returns an unconstrained type using
2699 -- an extended return statement since this part of the new inlining
2700 -- model which is not yet supported by the current implementation. ???
2704 Nkind
(First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
))))
2705 = N_Extended_Return_Statement
2706 and then not Back_End_Inlining
2711 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2712 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2714 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2715 -- can be replaced with calls to the renamed entity directly, because
2716 -- the subprograms are subtype conformant. If the renamed subprogram
2717 -- is an inherited operation, we must redo the expansion because
2718 -- implicit conversions may be needed. Similarly, if the renamed
2719 -- entity is inlined, expand the call for further optimizations.
2721 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2723 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
2730 -- Register the call in the list of inlined calls
2732 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
2734 -- Use generic machinery to copy body of inlined subprogram, as if it
2735 -- were an instantiation, resetting source locations appropriately, so
2736 -- that nested inlined calls appear in the main unit.
2738 Save_Env
(Subp
, Empty
);
2739 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2743 if not Back_End_Inlining
then
2748 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2750 Make_Block_Statement
(Loc
,
2751 Declarations
=> Declarations
(Bod
),
2752 Handled_Statement_Sequence
=>
2753 Handled_Statement_Sequence
(Bod
));
2755 if No
(Declarations
(Bod
)) then
2756 Set_Declarations
(Blk
, New_List
);
2759 -- For the unconstrained case, capture the name of the local
2760 -- variable that holds the result. This must be the first
2761 -- declaration in the block, because its bounds cannot depend
2762 -- on local variables. Otherwise there is no way to declare the
2763 -- result outside of the block. Needless to say, in general the
2764 -- bounds will depend on the actuals in the call.
2766 -- If the context is an assignment statement, as is the case
2767 -- for the expansion of an extended return, the left-hand side
2768 -- provides bounds even if the return type is unconstrained.
2772 First_Decl
: Node_Id
;
2775 First_Decl
:= First
(Declarations
(Blk
));
2777 if Nkind
(First_Decl
) /= N_Object_Declaration
then
2781 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2782 Targ1
:= Defining_Identifier
(First_Decl
);
2784 Targ1
:= Name
(Parent
(N
));
2801 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2803 Make_Block_Statement
(Loc
,
2804 Declarations
=> Declarations
(Bod
),
2805 Handled_Statement_Sequence
=>
2806 Handled_Statement_Sequence
(Bod
));
2808 -- Inline a call to a function that returns an unconstrained type.
2809 -- The semantic analyzer checked that frontend-inlined functions
2810 -- returning unconstrained types have no declarations and have
2811 -- a single extended return statement. As part of its processing
2812 -- the function was split in two subprograms: a procedure P and
2813 -- a function F that has a block with a call to procedure P (see
2814 -- Split_Unconstrained_Function).
2820 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2824 Blk_Stmt
: constant Node_Id
:=
2825 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
2826 First_Stmt
: constant Node_Id
:=
2827 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
2828 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
2832 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
2833 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
2834 and then No
(Next
(Second_Stmt
)));
2839 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
2840 Empty
, Instantiating
=> True);
2843 -- Capture the name of the local variable that holds the
2844 -- result. This must be the first declaration in the block,
2845 -- because its bounds cannot depend on local variables.
2846 -- Otherwise there is no way to declare the result outside
2847 -- of the block. Needless to say, in general the bounds will
2848 -- depend on the actuals in the call.
2850 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2851 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
2853 -- If the context is an assignment statement, as is the case
2854 -- for the expansion of an extended return, the left-hand
2855 -- side provides bounds even if the return type is
2859 Targ1
:= Name
(Parent
(N
));
2864 if No
(Declarations
(Bod
)) then
2865 Set_Declarations
(Blk
, New_List
);
2870 -- If this is a derived function, establish the proper return type
2872 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
2873 Ret_Type
:= Etype
(Orig_Subp
);
2875 Ret_Type
:= Etype
(Subp
);
2878 -- Create temporaries for the actuals that are expressions, or that are
2879 -- scalars and require copying to preserve semantics.
2881 F
:= First_Formal
(Subp
);
2882 A
:= First_Actual
(N
);
2883 while Present
(F
) loop
2884 if Present
(Renamed_Object
(F
)) then
2886 -- If expander is active, it is an error to try to inline a
2887 -- recursive program. In GNATprove mode, just indicate that the
2888 -- inlining will not happen, and mark the subprogram as not always
2891 if GNATprove_Mode
then
2893 ("cannot inline call to recursive subprogram?", N
, Subp
);
2894 Set_Is_Inlined_Always
(Subp
, False);
2897 ("cannot inline call to recursive subprogram", N
);
2903 -- Reset Last_Assignment for any parameters of mode out or in out, to
2904 -- prevent spurious warnings about overwriting for assignments to the
2905 -- formal in the inlined code.
2907 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
2908 Set_Last_Assignment
(Entity
(A
), Empty
);
2911 -- If the argument may be a controlling argument in a call within
2912 -- the inlined body, we must preserve its classwide nature to insure
2913 -- that dynamic dispatching take place subsequently. If the formal
2914 -- has a constraint it must be preserved to retain the semantics of
2917 if Is_Class_Wide_Type
(Etype
(F
))
2918 or else (Is_Access_Type
(Etype
(F
))
2919 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2921 Temp_Typ
:= Etype
(F
);
2923 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2924 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2926 Temp_Typ
:= Etype
(F
);
2928 Temp_Typ
:= Etype
(A
);
2931 -- If the actual is a simple name or a literal, no need to
2932 -- create a temporary, object can be used directly.
2934 -- If the actual is a literal and the formal has its address taken,
2935 -- we cannot pass the literal itself as an argument, so its value
2936 -- must be captured in a temporary.
2938 if (Is_Entity_Name
(A
)
2940 (not Is_Scalar_Type
(Etype
(A
))
2941 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
2943 -- When the actual is an identifier and the corresponding formal is
2944 -- used only once in the original body, the formal can be substituted
2945 -- directly with the actual parameter.
2947 or else (Nkind
(A
) = N_Identifier
2948 and then Formal_Is_Used_Once
(F
))
2951 (Nkind_In
(A
, N_Real_Literal
,
2953 N_Character_Literal
)
2954 and then not Address_Taken
(F
))
2956 if Etype
(F
) /= Etype
(A
) then
2958 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2960 Set_Renamed_Object
(F
, A
);
2964 Temp
:= Make_Temporary
(Loc
, 'C');
2966 -- If the actual for an in/in-out parameter is a view conversion,
2967 -- make it into an unchecked conversion, given that an untagged
2968 -- type conversion is not a proper object for a renaming.
2970 -- In-out conversions that involve real conversions have already
2971 -- been transformed in Expand_Actuals.
2973 if Nkind
(A
) = N_Type_Conversion
2974 and then Ekind
(F
) /= E_In_Parameter
2977 Make_Unchecked_Type_Conversion
(Loc
,
2978 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
2979 Expression
=> Relocate_Node
(Expression
(A
)));
2981 elsif Etype
(F
) /= Etype
(A
) then
2982 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
2983 Temp_Typ
:= Etype
(F
);
2986 New_A
:= Relocate_Node
(A
);
2989 Set_Sloc
(New_A
, Sloc
(N
));
2991 -- If the actual has a by-reference type, it cannot be copied,
2992 -- so its value is captured in a renaming declaration. Otherwise
2993 -- declare a local constant initialized with the actual.
2995 -- We also use a renaming declaration for expressions of an array
2996 -- type that is not bit-packed, both for efficiency reasons and to
2997 -- respect the semantics of the call: in most cases the original
2998 -- call will pass the parameter by reference, and thus the inlined
2999 -- code will have the same semantics.
3001 -- Finally, we need a renaming declaration in the case of limited
3002 -- types for which initialization cannot be by copy either.
3004 if Ekind
(F
) = E_In_Parameter
3005 and then not Is_By_Reference_Type
(Etype
(A
))
3006 and then not Is_Limited_Type
(Etype
(A
))
3008 (not Is_Array_Type
(Etype
(A
))
3009 or else not Is_Object_Reference
(A
)
3010 or else Is_Bit_Packed_Array
(Etype
(A
)))
3013 Make_Object_Declaration
(Loc
,
3014 Defining_Identifier
=> Temp
,
3015 Constant_Present
=> True,
3016 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3017 Expression
=> New_A
);
3020 Make_Object_Renaming_Declaration
(Loc
,
3021 Defining_Identifier
=> Temp
,
3022 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3026 Append
(Decl
, Decls
);
3027 Set_Renamed_Object
(F
, Temp
);
3034 -- Establish target of function call. If context is not assignment or
3035 -- declaration, create a temporary as a target. The declaration for the
3036 -- temporary may be subsequently optimized away if the body is a single
3037 -- expression, or if the left-hand side of the assignment is simple
3038 -- enough, i.e. an entity or an explicit dereference of one.
3040 if Ekind
(Subp
) = E_Function
then
3041 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3042 and then Is_Entity_Name
(Name
(Parent
(N
)))
3044 Targ
:= Name
(Parent
(N
));
3046 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3047 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3048 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3050 Targ
:= Name
(Parent
(N
));
3052 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3053 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3054 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3056 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3058 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3059 and then Is_Limited_Type
(Etype
(Subp
))
3061 Targ
:= Defining_Identifier
(Parent
(N
));
3063 -- New semantics: In an object declaration avoid an extra copy
3064 -- of the result of a call to an inlined function that returns
3065 -- an unconstrained type
3067 elsif Back_End_Inlining
3068 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3071 Targ
:= Defining_Identifier
(Parent
(N
));
3074 -- Replace call with temporary and create its declaration
3076 Temp
:= Make_Temporary
(Loc
, 'C');
3077 Set_Is_Internal
(Temp
);
3079 -- For the unconstrained case, the generated temporary has the
3080 -- same constrained declaration as the result variable. It may
3081 -- eventually be possible to remove that temporary and use the
3082 -- result variable directly.
3084 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3087 Make_Object_Declaration
(Loc
,
3088 Defining_Identifier
=> Temp
,
3089 Object_Definition
=>
3090 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3092 Replace_Formals
(Decl
);
3096 Make_Object_Declaration
(Loc
,
3097 Defining_Identifier
=> Temp
,
3098 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
3100 Set_Etype
(Temp
, Ret_Type
);
3103 Set_No_Initialization
(Decl
);
3104 Append
(Decl
, Decls
);
3105 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3110 Insert_Actions
(N
, Decls
);
3114 -- Special management for inlining a call to a function that returns
3115 -- an unconstrained type and initializes an object declaration: we
3116 -- avoid generating undesired extra calls and goto statements.
3119 -- function Func (...) return ...
3122 -- Result : String (1 .. 4);
3124 -- Proc (Result, ...);
3129 -- Result : String := Func (...);
3131 -- Replace this object declaration by:
3133 -- Result : String (1 .. 4);
3134 -- Proc (Result, ...);
3136 Remove_Homonym
(Targ
);
3139 Make_Object_Declaration
3141 Defining_Identifier
=> Targ
,
3142 Object_Definition
=>
3143 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3144 Replace_Formals
(Decl
);
3145 Rewrite
(Parent
(N
), Decl
);
3146 Analyze
(Parent
(N
));
3148 -- Avoid spurious warnings since we know that this declaration is
3149 -- referenced by the procedure call.
3151 Set_Never_Set_In_Source
(Targ
, False);
3153 -- Remove the local declaration of the extended return stmt from the
3156 Remove
(Parent
(Targ1
));
3158 -- Update the reference to the result (since we have rewriten the
3159 -- object declaration)
3162 Blk_Call_Stmt
: Node_Id
;
3165 -- Capture the call to the procedure
3168 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3170 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
3172 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
3173 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
3174 New_Occurrence_Of
(Targ
, Loc
));
3177 -- Remove the return statement
3180 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3181 N_Simple_Return_Statement
);
3183 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3186 -- Traverse the tree and replace formals with actuals or their thunks.
3187 -- Attach block to tree before analysis and rewriting.
3189 Replace_Formals
(Blk
);
3190 Set_Parent
(Blk
, N
);
3192 if GNATprove_Mode
then
3195 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
3201 -- No action needed since return statement has been already removed
3205 elsif Present
(Exit_Lab
) then
3207 -- If the body was a single expression, the single return statement
3208 -- and the corresponding label are useless.
3212 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3215 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3217 Append
(Lab_Decl
, (Declarations
(Blk
)));
3218 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3222 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3223 -- on conflicting private views that Gigi would ignore. If this is a
3224 -- predefined unit, analyze with checks off, as is done in the non-
3225 -- inlined run-time units.
3228 I_Flag
: constant Boolean := In_Inlined_Body
;
3231 In_Inlined_Body
:= True;
3235 Style
: constant Boolean := Style_Check
;
3238 Style_Check
:= False;
3240 -- Search for dispatching calls that use the Object.Operation
3241 -- notation using an Object that is a parameter of the inlined
3242 -- function. We reset the decoration of Operation to force
3243 -- the reanalysis of the inlined dispatching call because
3244 -- the actual object has been inlined.
3246 Reset_Dispatching_Calls
(Blk
);
3248 Analyze
(Blk
, Suppress
=> All_Checks
);
3249 Style_Check
:= Style
;
3256 In_Inlined_Body
:= I_Flag
;
3259 if Ekind
(Subp
) = E_Procedure
then
3260 Rewrite_Procedure_Call
(N
, Blk
);
3263 Rewrite_Function_Call
(N
, Blk
);
3268 -- For the unconstrained case, the replacement of the call has been
3269 -- made prior to the complete analysis of the generated declarations.
3270 -- Propagate the proper type now.
3273 if Nkind
(N
) = N_Identifier
then
3274 Set_Etype
(N
, Etype
(Entity
(N
)));
3276 Set_Etype
(N
, Etype
(Targ1
));
3283 -- Cleanup mapping between formals and actuals for other expansions
3285 F
:= First_Formal
(Subp
);
3286 while Present
(F
) loop
3287 Set_Renamed_Object
(F
, Empty
);
3290 end Expand_Inlined_Call
;
3292 --------------------------
3293 -- Get_Code_Unit_Entity --
3294 --------------------------
3296 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
3297 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
3300 if Ekind
(Unit
) = E_Package_Body
then
3301 Unit
:= Spec_Entity
(Unit
);
3305 end Get_Code_Unit_Entity
;
3307 ------------------------------
3308 -- Has_Excluded_Declaration --
3309 ------------------------------
3311 function Has_Excluded_Declaration
3313 Decls
: List_Id
) return Boolean
3317 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
3318 -- Nested subprograms make a given body ineligible for inlining, but
3319 -- we make an exception for instantiations of unchecked conversion.
3320 -- The body has not been analyzed yet, so check the name, and verify
3321 -- that the visible entity with that name is the predefined unit.
3323 -----------------------------
3324 -- Is_Unchecked_Conversion --
3325 -----------------------------
3327 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
3328 Id
: constant Node_Id
:= Name
(D
);
3332 if Nkind
(Id
) = N_Identifier
3333 and then Chars
(Id
) = Name_Unchecked_Conversion
3335 Conv
:= Current_Entity
(Id
);
3337 elsif Nkind_In
(Id
, N_Selected_Component
, N_Expanded_Name
)
3338 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
3340 Conv
:= Current_Entity
(Selector_Name
(Id
));
3345 return Present
(Conv
)
3346 and then Is_Predefined_File_Name
3347 (Unit_File_Name
(Get_Source_Unit
(Conv
)))
3348 and then Is_Intrinsic_Subprogram
(Conv
);
3349 end Is_Unchecked_Conversion
;
3351 -- Start of processing for Has_Excluded_Declaration
3354 -- No action needed if the check is not needed
3356 if not Check_Inlining_Restrictions
then
3361 while Present
(D
) loop
3362 if Nkind
(D
) = N_Subprogram_Body
then
3364 ("cannot inline & (nested subprogram)?",
3368 elsif Nkind
(D
) = N_Task_Type_Declaration
3369 or else Nkind
(D
) = N_Single_Task_Declaration
3372 ("cannot inline & (nested task type declaration)?",
3376 elsif Nkind
(D
) = N_Protected_Type_Declaration
3377 or else Nkind
(D
) = N_Single_Protected_Declaration
3380 ("cannot inline & (nested protected type declaration)?",
3384 elsif Nkind
(D
) = N_Package_Declaration
then
3386 ("cannot inline & (nested package declaration)?",
3390 elsif Nkind
(D
) = N_Function_Instantiation
3391 and then not Is_Unchecked_Conversion
(D
)
3394 ("cannot inline & (nested function instantiation)?",
3398 elsif Nkind
(D
) = N_Procedure_Instantiation
then
3400 ("cannot inline & (nested procedure instantiation)?",
3404 elsif Nkind
(D
) = N_Package_Instantiation
then
3406 ("cannot inline & (nested package instantiation)?",
3415 end Has_Excluded_Declaration
;
3417 ----------------------------
3418 -- Has_Excluded_Statement --
3419 ----------------------------
3421 function Has_Excluded_Statement
3423 Stats
: List_Id
) return Boolean
3429 -- No action needed if the check is not needed
3431 if not Check_Inlining_Restrictions
then
3436 while Present
(S
) loop
3437 if Nkind_In
(S
, N_Abort_Statement
,
3438 N_Asynchronous_Select
,
3439 N_Conditional_Entry_Call
,
3440 N_Delay_Relative_Statement
,
3441 N_Delay_Until_Statement
,
3446 ("cannot inline & (non-allowed statement)?", S
, Subp
);
3449 elsif Nkind
(S
) = N_Block_Statement
then
3450 if Present
(Declarations
(S
))
3451 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
3455 elsif Present
(Handled_Statement_Sequence
(S
)) then
3456 if not Back_End_Inlining
3459 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
3462 ("cannot inline& (exception handler)?",
3463 First
(Exception_Handlers
3464 (Handled_Statement_Sequence
(S
))),
3468 elsif Has_Excluded_Statement
3469 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3475 elsif Nkind
(S
) = N_Case_Statement
then
3476 E
:= First
(Alternatives
(S
));
3477 while Present
(E
) loop
3478 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
3485 elsif Nkind
(S
) = N_If_Statement
then
3486 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
3490 if Present
(Elsif_Parts
(S
)) then
3491 E
:= First
(Elsif_Parts
(S
));
3492 while Present
(E
) loop
3493 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
3501 if Present
(Else_Statements
(S
))
3502 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
3507 elsif Nkind
(S
) = N_Loop_Statement
3508 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
3512 elsif Nkind
(S
) = N_Extended_Return_Statement
then
3513 if Present
(Handled_Statement_Sequence
(S
))
3515 Has_Excluded_Statement
3516 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3520 elsif not Back_End_Inlining
3521 and then Present
(Handled_Statement_Sequence
(S
))
3523 Present
(Exception_Handlers
3524 (Handled_Statement_Sequence
(S
)))
3527 ("cannot inline& (exception handler)?",
3528 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
3538 end Has_Excluded_Statement
;
3540 --------------------------
3541 -- Has_Initialized_Type --
3542 --------------------------
3544 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
3545 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
3549 if No
(E_Body
) then -- imported subprogram
3553 Decl
:= First
(Declarations
(E_Body
));
3554 while Present
(Decl
) loop
3555 if Nkind
(Decl
) = N_Full_Type_Declaration
3556 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
3566 end Has_Initialized_Type
;
3568 -----------------------
3569 -- Has_Single_Return --
3570 -----------------------
3572 function Has_Single_Return
(N
: Node_Id
) return Boolean is
3573 Return_Statement
: Node_Id
:= Empty
;
3575 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
3581 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
3583 if Nkind
(N
) = N_Simple_Return_Statement
then
3584 if Present
(Expression
(N
))
3585 and then Is_Entity_Name
(Expression
(N
))
3587 if No
(Return_Statement
) then
3588 Return_Statement
:= N
;
3591 elsif Chars
(Expression
(N
)) =
3592 Chars
(Expression
(Return_Statement
))
3600 -- A return statement within an extended return is a noop
3603 elsif No
(Expression
(N
))
3605 Nkind
(Parent
(Parent
(N
))) = N_Extended_Return_Statement
3610 -- Expression has wrong form
3615 -- We can only inline a build-in-place function if it has a single
3618 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3619 if No
(Return_Statement
) then
3620 Return_Statement
:= N
;
3632 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
3634 -- Start of processing for Has_Single_Return
3637 if Check_All_Returns
(N
) /= OK
then
3640 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
3644 return Present
(Declarations
(N
))
3645 and then Present
(First
(Declarations
(N
)))
3646 and then Chars
(Expression
(Return_Statement
)) =
3647 Chars
(Defining_Identifier
(First
(Declarations
(N
))));
3649 end Has_Single_Return
;
3651 -----------------------------
3652 -- In_Main_Unit_Or_Subunit --
3653 -----------------------------
3655 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
3656 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
3659 -- Check whether the subprogram or package to inline is within the main
3660 -- unit or its spec or within a subunit. In either case there are no
3661 -- additional bodies to process. If the subprogram appears in a parent
3662 -- of the current unit, the check on whether inlining is possible is
3663 -- done in Analyze_Inlined_Bodies.
3665 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
3666 Comp
:= Library_Unit
(Comp
);
3669 return Comp
= Cunit
(Main_Unit
)
3670 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
3671 end In_Main_Unit_Or_Subunit
;
3677 procedure Initialize
is
3679 Pending_Descriptor
.Init
;
3680 Pending_Instantiations
.Init
;
3681 Inlined_Bodies
.Init
;
3685 for J
in Hash_Headers
'Range loop
3686 Hash_Headers
(J
) := No_Subp
;
3689 Inlined_Calls
:= No_Elist
;
3690 Backend_Calls
:= No_Elist
;
3691 Backend_Inlined_Subps
:= No_Elist
;
3692 Backend_Not_Inlined_Subps
:= No_Elist
;
3695 ------------------------
3696 -- Instantiate_Bodies --
3697 ------------------------
3699 -- Generic bodies contain all the non-local references, so an
3700 -- instantiation does not need any more context than Standard
3701 -- itself, even if the instantiation appears in an inner scope.
3702 -- Generic associations have verified that the contract model is
3703 -- satisfied, so that any error that may occur in the analysis of
3704 -- the body is an internal error.
3706 procedure Instantiate_Bodies
is
3708 Info
: Pending_Body_Info
;
3711 if Serious_Errors_Detected
= 0 then
3712 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
3713 Push_Scope
(Standard_Standard
);
3714 To_Clean
:= New_Elmt_List
;
3716 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3720 -- A body instantiation may generate additional instantiations, so
3721 -- the following loop must scan to the end of a possibly expanding
3722 -- set (that's why we can't simply use a FOR loop here).
3725 while J
<= Pending_Instantiations
.Last
3726 and then Serious_Errors_Detected
= 0
3728 Info
:= Pending_Instantiations
.Table
(J
);
3730 -- If the instantiation node is absent, it has been removed
3731 -- as part of unreachable code.
3733 if No
(Info
.Inst_Node
) then
3736 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
3737 Instantiate_Package_Body
(Info
);
3738 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
3741 Instantiate_Subprogram_Body
(Info
);
3747 -- Reset the table of instantiations. Additional instantiations
3748 -- may be added through inlining, when additional bodies are
3751 Pending_Instantiations
.Init
;
3753 -- We can now complete the cleanup actions of scopes that contain
3754 -- pending instantiations (skipped for generic units, since we
3755 -- never need any cleanups in generic units).
3756 -- pending instantiations.
3759 and then not Is_Generic_Unit
(Main_Unit_Entity
)
3762 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3768 end Instantiate_Bodies
;
3774 function Is_Nested
(E
: Entity_Id
) return Boolean is
3779 while Scop
/= Standard_Standard
loop
3780 if Ekind
(Scop
) in Subprogram_Kind
then
3783 elsif Ekind
(Scop
) = E_Task_Type
3784 or else Ekind
(Scop
) = E_Entry
3785 or else Ekind
(Scop
) = E_Entry_Family
3790 Scop
:= Scope
(Scop
);
3796 ------------------------
3797 -- List_Inlining_Info --
3798 ------------------------
3800 procedure List_Inlining_Info
is
3806 if not Debug_Flag_Dot_J
then
3810 -- Generate listing of calls inlined by the frontend
3812 if Present
(Inlined_Calls
) then
3814 Elmt
:= First_Elmt
(Inlined_Calls
);
3815 while Present
(Elmt
) loop
3818 if In_Extended_Main_Code_Unit
(Nod
) then
3822 Write_Str
("List of calls inlined by the frontend");
3829 Write_Location
(Sloc
(Nod
));
3838 -- Generate listing of calls passed to the backend
3840 if Present
(Backend_Calls
) then
3843 Elmt
:= First_Elmt
(Backend_Calls
);
3844 while Present
(Elmt
) loop
3847 if In_Extended_Main_Code_Unit
(Nod
) then
3851 Write_Str
("List of inlined calls passed to the backend");
3858 Write_Location
(Sloc
(Nod
));
3866 -- Generate listing of subprograms passed to the backend
3868 if Present
(Backend_Inlined_Subps
)
3869 and then Back_End_Inlining
3873 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
3874 while Present
(Elmt
) loop
3881 ("List of inlined subprograms passed to the backend");
3888 Write_Name
(Chars
(Nod
));
3890 Write_Location
(Sloc
(Nod
));
3898 -- Generate listing of subprograms that cannot be inlined by the backend
3900 if Present
(Backend_Not_Inlined_Subps
)
3901 and then Back_End_Inlining
3905 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
3906 while Present
(Elmt
) loop
3913 ("List of subprograms that cannot be inlined by the backend");
3920 Write_Name
(Chars
(Nod
));
3922 Write_Location
(Sloc
(Nod
));
3929 end List_Inlining_Info
;
3937 Pending_Instantiations
.Locked
:= True;
3938 Inlined_Bodies
.Locked
:= True;
3939 Successors
.Locked
:= True;
3940 Inlined
.Locked
:= True;
3941 Pending_Instantiations
.Release
;
3942 Inlined_Bodies
.Release
;
3947 ---------------------------
3948 -- Register_Backend_Call --
3949 ---------------------------
3951 procedure Register_Backend_Call
(N
: Node_Id
) is
3953 Append_New_Elmt
(N
, To
=> Backend_Calls
);
3954 end Register_Backend_Call
;
3956 --------------------------
3957 -- Remove_Dead_Instance --
3958 --------------------------
3960 procedure Remove_Dead_Instance
(N
: Node_Id
) is
3965 while J
<= Pending_Instantiations
.Last
loop
3966 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
3967 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
3973 end Remove_Dead_Instance
;
3975 --------------------
3976 -- Remove_Pragmas --
3977 --------------------
3979 procedure Remove_Pragmas
(Bod
: Node_Id
) is
3984 Decl
:= First
(Declarations
(Bod
));
3985 while Present
(Decl
) loop
3988 if Nkind
(Decl
) = N_Pragma
3989 and then Nam_In
(Pragma_Name
(Decl
), Name_Contract_Cases
,