1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Expander
; use Expander
;
33 with Exp_Ch6
; use Exp_Ch6
;
34 with Exp_Ch7
; use Exp_Ch7
;
35 with Exp_Tss
; use Exp_Tss
;
36 with Exp_Util
; use Exp_Util
;
37 with Fname
; use Fname
;
38 with Fname
.UF
; use Fname
.UF
;
40 with Namet
; use Namet
;
41 with Nmake
; use Nmake
;
42 with Nlists
; use Nlists
;
43 with Output
; use Output
;
44 with Sem_Aux
; use Sem_Aux
;
45 with Sem_Ch8
; use Sem_Ch8
;
46 with Sem_Ch10
; use Sem_Ch10
;
47 with Sem_Ch12
; use Sem_Ch12
;
48 with Sem_Prag
; use Sem_Prag
;
49 with Sem_Util
; use Sem_Util
;
50 with Sinfo
; use Sinfo
;
51 with Sinput
; use Sinput
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Uname
; use Uname
;
55 with Tbuild
; use Tbuild
;
57 package body Inline
is
59 Check_Inlining_Restrictions
: constant Boolean := True;
60 -- In the following cases the frontend rejects inlining because they
61 -- are not handled well by the backend. This variable facilitates
62 -- disabling these restrictions to evaluate future versions of the
63 -- GCC backend in which some of the restrictions may be supported.
65 -- - subprograms that have:
66 -- - nested subprograms
68 -- - package declarations
69 -- - task or protected object declarations
70 -- - some of the following statements:
72 -- - asynchronous-select
73 -- - conditional-entry-call
79 Inlined_Calls
: Elist_Id
;
80 -- List of frontend inlined calls
82 Backend_Calls
: Elist_Id
;
83 -- List of inline calls passed to the backend
85 Backend_Inlined_Subps
: Elist_Id
;
86 -- List of subprograms inlined by the backend
88 Backend_Not_Inlined_Subps
: Elist_Id
;
89 -- List of subprograms that cannot be inlined by the backend
95 -- Inlined functions are actually placed in line by the backend if the
96 -- corresponding bodies are available (i.e. compiled). Whenever we find
97 -- a call to an inlined subprogram, we add the name of the enclosing
98 -- compilation unit to a worklist. After all compilation, and after
99 -- expansion of generic bodies, we traverse the list of pending bodies
100 -- and compile them as well.
102 package Inlined_Bodies
is new Table
.Table
(
103 Table_Component_Type
=> Entity_Id
,
104 Table_Index_Type
=> Int
,
105 Table_Low_Bound
=> 0,
106 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
107 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
108 Table_Name
=> "Inlined_Bodies");
110 -----------------------
111 -- Inline Processing --
112 -----------------------
114 -- For each call to an inlined subprogram, we make entries in a table
115 -- that stores caller and callee, and indicates the call direction from
116 -- one to the other. We also record the compilation unit that contains
117 -- the callee. After analyzing the bodies of all such compilation units,
118 -- we compute the transitive closure of inlined subprograms called from
119 -- the main compilation unit and make it available to the code generator
120 -- in no particular order, thus allowing cycles in the call graph.
122 Last_Inlined
: Entity_Id
:= Empty
;
124 -- For each entry in the table we keep a list of successors in topological
125 -- order, i.e. callers of the current subprogram.
127 type Subp_Index
is new Nat
;
128 No_Subp
: constant Subp_Index
:= 0;
130 -- The subprogram entities are hashed into the Inlined table
132 Num_Hash_Headers
: constant := 512;
134 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
137 type Succ_Index
is new Nat
;
138 No_Succ
: constant Succ_Index
:= 0;
140 type Succ_Info
is record
145 -- The following table stores list elements for the successor lists. These
146 -- lists cannot be chained directly through entries in the Inlined table,
147 -- because a given subprogram can appear in several such lists.
149 package Successors
is new Table
.Table
(
150 Table_Component_Type
=> Succ_Info
,
151 Table_Index_Type
=> Succ_Index
,
152 Table_Low_Bound
=> 1,
153 Table_Initial
=> Alloc
.Successors_Initial
,
154 Table_Increment
=> Alloc
.Successors_Increment
,
155 Table_Name
=> "Successors");
157 type Subp_Info
is record
158 Name
: Entity_Id
:= Empty
;
159 Next
: Subp_Index
:= No_Subp
;
160 First_Succ
: Succ_Index
:= No_Succ
;
161 Listed
: Boolean := False;
162 Main_Call
: Boolean := False;
163 Processed
: Boolean := False;
166 package Inlined
is new Table
.Table
(
167 Table_Component_Type
=> Subp_Info
,
168 Table_Index_Type
=> Subp_Index
,
169 Table_Low_Bound
=> 1,
170 Table_Initial
=> Alloc
.Inlined_Initial
,
171 Table_Increment
=> Alloc
.Inlined_Increment
,
172 Table_Name
=> "Inlined");
174 -----------------------
175 -- Local Subprograms --
176 -----------------------
178 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
179 -- Make two entries in Inlined table, for an inlined subprogram being
180 -- called, and for the inlined subprogram that contains the call. If
181 -- the call is in the main compilation unit, Caller is Empty.
183 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
);
184 -- Add the subprogram to the list of inlined subprogram for the unit
186 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
187 -- Make entry in Inlined table for subprogram E, or return table index
188 -- that already holds E.
190 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
;
191 pragma Inline
(Get_Code_Unit_Entity
);
192 -- Return the entity node for the unit containing E. Always return the spec
195 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
196 -- If a candidate for inlining contains type declarations for types with
197 -- non-trivial initialization procedures, they are not worth inlining.
199 function Has_Single_Return
(N
: Node_Id
) return Boolean;
200 -- In general we cannot inline functions that return unconstrained type.
201 -- However, we can handle such functions if all return statements return a
202 -- local variable that is the only declaration in the body of the function.
203 -- In that case the call can be replaced by that local variable as is done
204 -- for other inlined calls.
206 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean;
207 -- Return True if E is in the main unit or its spec or in a subunit
209 function Is_Nested
(E
: Entity_Id
) return Boolean;
210 -- If the function is nested inside some other function, it will always
211 -- be compiled if that function is, so don't add it to the inline list.
212 -- We cannot compile a nested function outside the scope of the containing
213 -- function anyway. This is also the case if the function is defined in a
214 -- task body or within an entry (for example, an initialization procedure).
216 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
);
217 -- Remove all aspects and/or pragmas that have no meaning in inlined body
218 -- Body_Decl. The analysis of these items is performed on the non-inlined
219 -- body. The items currently removed are:
232 ------------------------------
233 -- Deferred Cleanup Actions --
234 ------------------------------
236 -- The cleanup actions for scopes that contain instantiations is delayed
237 -- until after expansion of those instantiations, because they may contain
238 -- finalizable objects or tasks that affect the cleanup code. A scope
239 -- that contains instantiations only needs to be finalized once, even
240 -- if it contains more than one instance. We keep a list of scopes
241 -- that must still be finalized, and call cleanup_actions after all
242 -- the instantiations have been completed.
246 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
247 -- Build set of scopes on which cleanup actions must be performed
249 procedure Cleanup_Scopes
;
250 -- Complete cleanup actions on scopes that need it
256 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
257 P1
: constant Subp_Index
:= Add_Subp
(Called
);
262 if Present
(Caller
) then
263 P2
:= Add_Subp
(Caller
);
265 -- Add P1 to the list of successors of P2, if not already there.
266 -- Note that P2 may contain more than one call to P1, and only
267 -- one needs to be recorded.
269 J
:= Inlined
.Table
(P2
).First_Succ
;
270 while J
/= No_Succ
loop
271 if Successors
.Table
(J
).Subp
= P1
then
275 J
:= Successors
.Table
(J
).Next
;
278 -- On exit, make a successor entry for P1
280 Successors
.Increment_Last
;
281 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
282 Successors
.Table
(Successors
.Last
).Next
:=
283 Inlined
.Table
(P2
).First_Succ
;
284 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
286 Inlined
.Table
(P1
).Main_Call
:= True;
290 ----------------------
291 -- Add_Inlined_Body --
292 ----------------------
294 procedure Add_Inlined_Body
(E
: Entity_Id
; N
: Node_Id
) is
296 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
297 -- Level of inlining for the call: Dont_Inline means no inlining,
298 -- Inline_Call means that only the call is considered for inlining,
299 -- Inline_Package means that the call is considered for inlining and
300 -- its package compiled and scanned for more inlining opportunities.
302 function Must_Inline
return Inline_Level_Type
;
303 -- Inlining is only done if the call statement N is in the main unit,
304 -- or within the body of another inlined subprogram.
310 function Must_Inline
return Inline_Level_Type
is
315 -- Check if call is in main unit
317 Scop
:= Current_Scope
;
319 -- Do not try to inline if scope is standard. This could happen, for
320 -- example, for a call to Add_Global_Declaration, and it causes
321 -- trouble to try to inline at this level.
323 if Scop
= Standard_Standard
then
327 -- Otherwise lookup scope stack to outer scope
329 while Scope
(Scop
) /= Standard_Standard
330 and then not Is_Child_Unit
(Scop
)
332 Scop
:= Scope
(Scop
);
335 Comp
:= Parent
(Scop
);
336 while Nkind
(Comp
) /= N_Compilation_Unit
loop
337 Comp
:= Parent
(Comp
);
340 -- If the call is in the main unit, inline the call and compile the
341 -- package of the subprogram to find more calls to be inlined.
343 if Comp
= Cunit
(Main_Unit
)
344 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
347 return Inline_Package
;
350 -- The call is not in the main unit. See if it is in some inlined
351 -- subprogram. If so, inline the call and, if the inlining level is
352 -- set to 1, stop there; otherwise also compile the package as above.
354 Scop
:= Current_Scope
;
355 while Scope
(Scop
) /= Standard_Standard
356 and then not Is_Child_Unit
(Scop
)
358 if Is_Overloadable
(Scop
) and then Is_Inlined
(Scop
) then
361 if Inline_Level
= 1 then
364 return Inline_Package
;
368 Scop
:= Scope
(Scop
);
374 Level
: Inline_Level_Type
;
376 -- Start of processing for Add_Inlined_Body
379 Append_New_Elmt
(N
, To
=> Backend_Calls
);
381 -- Find unit containing E, and add to list of inlined bodies if needed.
382 -- If the body is already present, no need to load any other unit. This
383 -- is the case for an initialization procedure, which appears in the
384 -- package declaration that contains the type. It is also the case if
385 -- the body has already been analyzed. Finally, if the unit enclosing
386 -- E is an instance, the instance body will be analyzed in any case,
387 -- and there is no need to add the enclosing unit (whose body might not
390 -- Library-level functions must be handled specially, because there is
391 -- no enclosing package to retrieve. In this case, it is the body of
392 -- the function that will have to be loaded.
394 if Is_Abstract_Subprogram
(E
)
395 or else Is_Nested
(E
)
396 or else Convention
(E
) = Convention_Protected
401 Level
:= Must_Inline
;
403 if Level
/= Dont_Inline
then
405 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
410 -- Library-level inlined function. Add function itself to
411 -- list of needed units.
414 Inlined_Bodies
.Increment_Last
;
415 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
417 elsif Ekind
(Pack
) = E_Package
then
420 if Is_Generic_Instance
(Pack
) then
423 -- Do not inline the package if the subprogram is an init proc
424 -- or other internally generated subprogram, because in that
425 -- case the subprogram body appears in the same unit that
426 -- declares the type, and that body is visible to the back end.
427 -- Do not inline it either if it is in the main unit.
429 elsif Level
= Inline_Package
430 and then not Is_Inlined
(Pack
)
431 and then not Is_Internal
(E
)
432 and then not In_Main_Unit_Or_Subunit
(Pack
)
434 Set_Is_Inlined
(Pack
);
435 Inlined_Bodies
.Increment_Last
;
436 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
438 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
439 -- calls if the back-end takes care of inlining the call.
441 elsif Level
= Inline_Call
442 and then Has_Pragma_Inline_Always
(E
)
443 and then Back_End_Inlining
445 Set_Is_Inlined
(Pack
);
446 Inlined_Bodies
.Increment_Last
;
447 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
451 -- If the call was generated by the compiler and is to a function
452 -- in a run-time unit, we need to suppress debugging information
453 -- for it, so that the code that is eventually inlined will not
454 -- affect debugging of the program. We do not do it if the call
455 -- comes from source because, even if the call is inlined, the
456 -- user may expect it to be present in the debugging information.
458 if not Comes_From_Source
(N
)
459 and then In_Extended_Main_Source_Unit
(N
)
461 Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(E
)))
463 Set_Needs_Debug_Info
(E
, False);
467 end Add_Inlined_Body
;
469 ----------------------------
470 -- Add_Inlined_Subprogram --
471 ----------------------------
473 procedure Add_Inlined_Subprogram
(Index
: Subp_Index
) is
474 E
: constant Entity_Id
:= Inlined
.Table
(Index
).Name
;
475 Decl
: constant Node_Id
:= Parent
(Declaration_Node
(E
));
476 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
478 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
479 -- Append Subp to the list of subprograms inlined by the backend
481 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
482 -- Append Subp to the list of subprograms that cannot be inlined by
485 -----------------------------------------
486 -- Register_Backend_Inlined_Subprogram --
487 -----------------------------------------
489 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
491 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
492 end Register_Backend_Inlined_Subprogram
;
494 ---------------------------------------------
495 -- Register_Backend_Not_Inlined_Subprogram --
496 ---------------------------------------------
498 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
500 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
501 end Register_Backend_Not_Inlined_Subprogram
;
503 -- Start of processing for Add_Inlined_Subprogram
506 -- If the subprogram is to be inlined, and if its unit is known to be
507 -- inlined or is an instance whose body will be analyzed anyway or the
508 -- subprogram was generated as a body by the compiler (for example an
509 -- initialization procedure) or its declaration was provided along with
510 -- the body (for example an expression function), and if it is declared
511 -- at the library level not in the main unit, and if it can be inlined
512 -- by the back-end, then insert it in the list of inlined subprograms.
515 and then (Is_Inlined
(Pack
)
516 or else Is_Generic_Instance
(Pack
)
517 or else Nkind
(Decl
) = N_Subprogram_Body
518 or else Present
(Corresponding_Body
(Decl
)))
519 and then not In_Main_Unit_Or_Subunit
(E
)
520 and then not Is_Nested
(E
)
521 and then not Has_Initialized_Type
(E
)
523 Register_Backend_Inlined_Subprogram
(E
);
525 if No
(Last_Inlined
) then
526 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
528 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
534 Register_Backend_Not_Inlined_Subprogram
(E
);
537 Inlined
.Table
(Index
).Listed
:= True;
538 end Add_Inlined_Subprogram
;
540 ------------------------
541 -- Add_Scope_To_Clean --
542 ------------------------
544 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
545 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
549 -- If the instance appears in a library-level package declaration,
550 -- all finalization is global, and nothing needs doing here.
552 if Scop
= Standard_Standard
then
556 -- If the instance is within a generic unit, no finalization code
557 -- can be generated. Note that at this point all bodies have been
558 -- analyzed, and the scope stack itself is not present, and the flag
559 -- Inside_A_Generic is not set.
566 while Present
(S
) and then S
/= Standard_Standard
loop
567 if Is_Generic_Unit
(S
) then
575 Elmt
:= First_Elmt
(To_Clean
);
576 while Present
(Elmt
) loop
577 if Node
(Elmt
) = Scop
then
581 Elmt
:= Next_Elmt
(Elmt
);
584 Append_Elmt
(Scop
, To_Clean
);
585 end Add_Scope_To_Clean
;
591 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
592 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
596 -- Initialize entry in Inlined table
598 procedure New_Entry
is
600 Inlined
.Increment_Last
;
601 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
602 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
603 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
604 Inlined
.Table
(Inlined
.Last
).Listed
:= False;
605 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
606 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
609 -- Start of processing for Add_Subp
612 if Hash_Headers
(Index
) = No_Subp
then
614 Hash_Headers
(Index
) := Inlined
.Last
;
618 J
:= Hash_Headers
(Index
);
619 while J
/= No_Subp
loop
620 if Inlined
.Table
(J
).Name
= E
then
624 J
:= Inlined
.Table
(J
).Next
;
628 -- On exit, subprogram was not found. Enter in table. Index is
629 -- the current last entry on the hash chain.
632 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
637 ----------------------------
638 -- Analyze_Inlined_Bodies --
639 ----------------------------
641 procedure Analyze_Inlined_Bodies
is
648 type Pending_Index
is new Nat
;
650 package Pending_Inlined
is new Table
.Table
(
651 Table_Component_Type
=> Subp_Index
,
652 Table_Index_Type
=> Pending_Index
,
653 Table_Low_Bound
=> 1,
654 Table_Initial
=> Alloc
.Inlined_Initial
,
655 Table_Increment
=> Alloc
.Inlined_Increment
,
656 Table_Name
=> "Pending_Inlined");
657 -- The workpile used to compute the transitive closure
659 function Is_Ancestor_Of_Main
661 Nam
: Node_Id
) return Boolean;
662 -- Determine whether the unit whose body is loaded is an ancestor of
663 -- the main unit, and has a with_clause on it. The body is not
664 -- analyzed yet, so the check is purely lexical: the name of the with
665 -- clause is a selected component, and names of ancestors must match.
667 -------------------------
668 -- Is_Ancestor_Of_Main --
669 -------------------------
671 function Is_Ancestor_Of_Main
673 Nam
: Node_Id
) return Boolean
678 if Nkind
(Nam
) /= N_Selected_Component
then
682 if Chars
(Selector_Name
(Nam
)) /=
683 Chars
(Cunit_Entity
(Main_Unit
))
688 Pref
:= Prefix
(Nam
);
689 if Nkind
(Pref
) = N_Identifier
then
691 -- Par is an ancestor of Par.Child.
693 return Chars
(Pref
) = Chars
(U_Name
);
695 elsif Nkind
(Pref
) = N_Selected_Component
696 and then Chars
(Selector_Name
(Pref
)) = Chars
(U_Name
)
698 -- Par.Child is an ancestor of Par.Child.Grand.
700 return True; -- should check that ancestor match
703 -- A is an ancestor of A.B.C if it is an ancestor of A.B
705 return Is_Ancestor_Of_Main
(U_Name
, Pref
);
708 end Is_Ancestor_Of_Main
;
710 -- Start of processing for Analyze_Inlined_Bodies
713 if Serious_Errors_Detected
= 0 then
714 Push_Scope
(Standard_Standard
);
717 while J
<= Inlined_Bodies
.Last
718 and then Serious_Errors_Detected
= 0
720 Pack
:= Inlined_Bodies
.Table
(J
);
722 and then Scope
(Pack
) /= Standard_Standard
723 and then not Is_Child_Unit
(Pack
)
725 Pack
:= Scope
(Pack
);
728 Comp_Unit
:= Parent
(Pack
);
729 while Present
(Comp_Unit
)
730 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
732 Comp_Unit
:= Parent
(Comp_Unit
);
735 -- Load the body, unless it is the main unit, or is an instance
736 -- whose body has already been analyzed.
738 if Present
(Comp_Unit
)
739 and then Comp_Unit
/= Cunit
(Main_Unit
)
740 and then Body_Required
(Comp_Unit
)
741 and then (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
742 or else No
(Corresponding_Body
(Unit
(Comp_Unit
))))
745 Bname
: constant Unit_Name_Type
:=
746 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
751 if not Is_Loaded
(Bname
) then
752 Style_Check
:= False;
753 Load_Needed_Body
(Comp_Unit
, OK
, Do_Analyze
=> False);
757 -- Warn that a body was not available for inlining
760 Error_Msg_Unit_1
:= Bname
;
762 ("one or more inlined subprograms accessed in $!??",
765 Get_File_Name
(Bname
, Subunit
=> False);
766 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
769 -- If the package to be inlined is an ancestor unit of
770 -- the main unit, and it has a semantic dependence on
771 -- it, the inlining cannot take place to prevent an
772 -- elaboration circularity. The desired body is not
773 -- analyzed yet, to prevent the completion of Taft
774 -- amendment types that would lead to elaboration
775 -- circularities in gigi.
778 U_Id
: constant Entity_Id
:=
779 Defining_Entity
(Unit
(Comp_Unit
));
780 Body_Unit
: constant Node_Id
:=
781 Library_Unit
(Comp_Unit
);
785 Item
:= First
(Context_Items
(Body_Unit
));
786 while Present
(Item
) loop
787 if Nkind
(Item
) = N_With_Clause
789 Is_Ancestor_Of_Main
(U_Id
, Name
(Item
))
791 Set_Is_Inlined
(U_Id
, False);
798 -- If no suspicious with_clauses, analyze the body.
800 if Is_Inlined
(U_Id
) then
801 Semantics
(Body_Unit
);
811 if J
> Inlined_Bodies
.Last
then
813 -- The analysis of required bodies may have produced additional
814 -- generic instantiations. To obtain further inlining, we need
815 -- to perform another round of generic body instantiations.
819 -- Symmetrically, the instantiation of required generic bodies
820 -- may have caused additional bodies to be inlined. To obtain
821 -- further inlining, we keep looping over the inlined bodies.
825 -- The list of inlined subprograms is an overestimate, because it
826 -- includes inlined functions called from functions that are compiled
827 -- as part of an inlined package, but are not themselves called. An
828 -- accurate computation of just those subprograms that are needed
829 -- requires that we perform a transitive closure over the call graph,
830 -- starting from calls in the main program.
832 for Index
in Inlined
.First
.. Inlined
.Last
loop
833 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
835 -- This means that Add_Inlined_Body added the subprogram to the
836 -- table but wasn't able to handle its code unit. Do nothing.
838 Inlined
.Table
(Index
).Processed
:= True;
840 elsif Inlined
.Table
(Index
).Main_Call
then
841 Pending_Inlined
.Increment_Last
;
842 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
843 Inlined
.Table
(Index
).Processed
:= True;
846 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
850 -- Iterate over the workpile until it is emptied, propagating the
851 -- Is_Called flag to the successors of the processed subprogram.
853 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
854 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
855 Pending_Inlined
.Decrement_Last
;
857 S
:= Inlined
.Table
(Subp
).First_Succ
;
859 while S
/= No_Succ
loop
860 Subp
:= Successors
.Table
(S
).Subp
;
862 if not Inlined
.Table
(Subp
).Processed
then
863 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
864 Pending_Inlined
.Increment_Last
;
865 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
866 Inlined
.Table
(Subp
).Processed
:= True;
869 S
:= Successors
.Table
(S
).Next
;
873 -- Finally add the called subprograms to the list of inlined
874 -- subprograms for the unit.
876 for Index
in Inlined
.First
.. Inlined
.Last
loop
877 if Is_Called
(Inlined
.Table
(Index
).Name
)
878 and then not Inlined
.Table
(Index
).Listed
880 Add_Inlined_Subprogram
(Index
);
886 end Analyze_Inlined_Bodies
;
888 --------------------------
889 -- Build_Body_To_Inline --
890 --------------------------
892 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
893 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
894 Analysis_Status
: constant Boolean := Full_Analysis
;
895 Original_Body
: Node_Id
;
896 Body_To_Analyze
: Node_Id
;
897 Max_Size
: constant := 10;
899 function Has_Pending_Instantiation
return Boolean;
900 -- If some enclosing body contains instantiations that appear before
901 -- the corresponding generic body, the enclosing body has a freeze node
902 -- so that it can be elaborated after the generic itself. This might
903 -- conflict with subsequent inlinings, so that it is unsafe to try to
904 -- inline in such a case.
906 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
907 -- This function is called only in GNATprove mode, and it returns
908 -- True if the subprogram has no return statement or a single return
909 -- statement as last statement. It returns False for subprogram with
910 -- a single return as last statement inside one or more blocks, as
911 -- inlining would generate gotos in that case as well (although the
912 -- goto is useless in that case).
914 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
915 -- If the body of the subprogram includes a call that returns an
916 -- unconstrained type, the secondary stack is involved, and it
917 -- is not worth inlining.
919 -------------------------------
920 -- Has_Pending_Instantiation --
921 -------------------------------
923 function Has_Pending_Instantiation
return Boolean is
928 while Present
(S
) loop
929 if Is_Compilation_Unit
(S
)
930 or else Is_Child_Unit
(S
)
934 elsif Ekind
(S
) = E_Package
935 and then Has_Forward_Instantiation
(S
)
944 end Has_Pending_Instantiation
;
946 -----------------------------------------
947 -- Has_Single_Return_In_GNATprove_Mode --
948 -----------------------------------------
950 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
951 Last_Statement
: Node_Id
:= Empty
;
953 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
954 -- Returns OK on node N if this is not a return statement different
955 -- from the last statement in the subprogram.
961 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
963 if Nkind_In
(N
, N_Simple_Return_Statement
,
964 N_Extended_Return_Statement
)
966 if N
= Last_Statement
then
977 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
979 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
982 -- Retrieve the last statement
984 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
986 -- Check that the last statement is the only possible return
987 -- statement in the subprogram.
989 return Check_All_Returns
(N
) = OK
;
990 end Has_Single_Return_In_GNATprove_Mode
;
992 --------------------------
993 -- Uses_Secondary_Stack --
994 --------------------------
996 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
997 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
998 -- Look for function calls that return an unconstrained type
1004 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
1006 if Nkind
(N
) = N_Function_Call
1007 and then Is_Entity_Name
(Name
(N
))
1008 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
1009 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
1012 ("cannot inline & (call returns unconstrained type)?",
1020 function Check_Calls
is new Traverse_Func
(Check_Call
);
1023 return Check_Calls
(Bod
) = Abandon
;
1024 end Uses_Secondary_Stack
;
1026 -- Start of processing for Build_Body_To_Inline
1029 -- Return immediately if done already
1031 if Nkind
(Decl
) = N_Subprogram_Declaration
1032 and then Present
(Body_To_Inline
(Decl
))
1036 -- Subprograms that have return statements in the middle of the body are
1037 -- inlined with gotos. GNATprove does not currently support gotos, so
1038 -- we prevent such inlining.
1040 elsif GNATprove_Mode
1041 and then not Has_Single_Return_In_GNATprove_Mode
1043 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1046 -- Functions that return unconstrained composite types require
1047 -- secondary stack handling, and cannot currently be inlined, unless
1048 -- all return statements return a local variable that is the first
1049 -- local declaration in the body.
1051 elsif Ekind
(Spec_Id
) = E_Function
1052 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1053 and then not Is_Access_Type
(Etype
(Spec_Id
))
1054 and then not Is_Constrained
(Etype
(Spec_Id
))
1056 if not Has_Single_Return
(N
) then
1058 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1062 -- Ditto for functions that return controlled types, where controlled
1063 -- actions interfere in complex ways with inlining.
1065 elsif Ekind
(Spec_Id
) = E_Function
1066 and then Needs_Finalization
(Etype
(Spec_Id
))
1069 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1073 if Present
(Declarations
(N
))
1074 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1079 if Present
(Handled_Statement_Sequence
(N
)) then
1080 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1082 ("cannot inline& (exception handler)?",
1083 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1087 elsif Has_Excluded_Statement
1088 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1094 -- We do not inline a subprogram that is too large, unless it is marked
1095 -- Inline_Always or we are in GNATprove mode. This pragma does not
1096 -- suppress the other checks on inlining (forbidden declarations,
1099 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1100 and then List_Length
1101 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1103 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1107 if Has_Pending_Instantiation
then
1109 ("cannot inline& (forward instance within enclosing body)?",
1114 -- Within an instance, the body to inline must be treated as a nested
1115 -- generic, so that the proper global references are preserved.
1117 -- Note that we do not do this at the library level, because it is not
1118 -- needed, and furthermore this causes trouble if front end inlining
1119 -- is activated (-gnatN).
1121 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1122 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1123 Original_Body
:= Copy_Generic_Node
(N
, Empty
, True);
1125 Original_Body
:= Copy_Separate_Tree
(N
);
1128 -- We need to capture references to the formals in order to substitute
1129 -- the actuals at the point of inlining, i.e. instantiation. To treat
1130 -- the formals as globals to the body to inline, we nest it within a
1131 -- dummy parameterless subprogram, declared within the real one. To
1132 -- avoid generating an internal name (which is never public, and which
1133 -- affects serial numbers of other generated names), we use an internal
1134 -- symbol that cannot conflict with user declarations.
1136 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1137 Set_Defining_Unit_Name
1138 (Specification
(Original_Body
),
1139 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1140 Set_Corresponding_Spec
(Original_Body
, Empty
);
1142 -- Remove all aspects/pragmas that have no meaining in an inlined body
1144 Remove_Aspects_And_Pragmas
(Original_Body
);
1146 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1148 -- Set return type of function, which is also global and does not need
1151 if Ekind
(Spec_Id
) = E_Function
then
1152 Set_Result_Definition
1153 (Specification
(Body_To_Analyze
),
1154 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1157 if No
(Declarations
(N
)) then
1158 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1160 Append
(Body_To_Analyze
, Declarations
(N
));
1163 -- The body to inline is pre-analyzed. In GNATprove mode we must disable
1164 -- full analysis as well so that light expansion does not take place
1165 -- either, and name resolution is unaffected.
1167 Expander_Mode_Save_And_Set
(False);
1168 Full_Analysis
:= False;
1170 Analyze
(Body_To_Analyze
);
1171 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1172 Save_Global_References
(Original_Body
);
1174 Remove
(Body_To_Analyze
);
1176 Expander_Mode_Restore
;
1177 Full_Analysis
:= Analysis_Status
;
1179 -- Restore environment if previously saved
1181 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1185 -- If secondary stack is used, there is no point in inlining. We have
1186 -- already issued the warning in this case, so nothing to do.
1188 if Uses_Secondary_Stack
(Body_To_Analyze
) then
1192 Set_Body_To_Inline
(Decl
, Original_Body
);
1193 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1194 Set_Is_Inlined
(Spec_Id
);
1195 end Build_Body_To_Inline
;
1201 procedure Cannot_Inline
1205 Is_Serious
: Boolean := False)
1208 -- In GNATprove mode, inlining is the technical means by which the
1209 -- higher-level goal of contextual analysis is reached, so issue
1210 -- messages about failure to apply contextual analysis to a
1211 -- subprogram, rather than failure to inline it.
1214 and then Msg
(Msg
'First .. Msg
'First + 12) = "cannot inline"
1217 Len1
: constant Positive :=
1218 String (String'("cannot inline"))'Length;
1219 Len2 : constant Positive :=
1220 String (String'("info: no contextual analysis of"))'Length;
1222 New_Msg
: String (1 .. Msg
'Length + Len2
- Len1
);
1225 New_Msg
(1 .. Len2
) := "info: no contextual analysis of";
1226 New_Msg
(Len2
+ 1 .. Msg
'Length + Len2
- Len1
) :=
1227 Msg
(Msg
'First + Len1
.. Msg
'Last);
1228 Cannot_Inline
(New_Msg
, N
, Subp
, Is_Serious
);
1233 pragma Assert
(Msg
(Msg
'Last) = '?');
1235 -- Legacy front end inlining model
1237 if not Back_End_Inlining
then
1239 -- Do not emit warning if this is a predefined unit which is not
1240 -- the main unit. With validity checks enabled, some predefined
1241 -- subprograms may contain nested subprograms and become ineligible
1244 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1245 and then not In_Extended_Main_Source_Unit
(Subp
)
1249 -- In GNATprove mode, issue a warning, and indicate that the
1250 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1253 elsif GNATprove_Mode
then
1254 Set_Is_Inlined_Always
(Subp
, False);
1255 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1257 elsif Has_Pragma_Inline_Always
(Subp
) then
1259 -- Remove last character (question mark) to make this into an
1260 -- error, because the Inline_Always pragma cannot be obeyed.
1262 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1264 elsif Ineffective_Inline_Warnings
then
1265 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1268 -- New semantics relying on back end inlining
1270 elsif Is_Serious
then
1272 -- Remove last character (question mark) to make this into an error.
1274 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1276 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1277 -- is not always inlined by setting flag Is_Inlined_Always to False.
1279 elsif GNATprove_Mode
then
1280 Set_Is_Inlined_Always
(Subp
, False);
1281 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1285 -- Do not emit warning if this is a predefined unit which is not
1286 -- the main unit. This behavior is currently provided for backward
1287 -- compatibility but it will be removed when we enforce the
1288 -- strictness of the new rules.
1290 if Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit
(Subp
)))
1291 and then not In_Extended_Main_Source_Unit
(Subp
)
1295 elsif Has_Pragma_Inline_Always
(Subp
) then
1297 -- Emit a warning if this is a call to a runtime subprogram
1298 -- which is located inside a generic. Previously this call
1299 -- was silently skipped.
1301 if Is_Generic_Instance
(Subp
) then
1303 Gen_P
: constant Entity_Id
:= Generic_Parent
(Parent
(Subp
));
1305 if Is_Predefined_File_Name
1306 (Unit_File_Name
(Get_Source_Unit
(Gen_P
)))
1308 Set_Is_Inlined
(Subp
, False);
1309 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1315 -- Remove last character (question mark) to make this into an
1316 -- error, because the Inline_Always pragma cannot be obeyed.
1318 Error_Msg_NE
(Msg
(Msg
'First .. Msg
'Last - 1), N
, Subp
);
1321 Set_Is_Inlined
(Subp
, False);
1323 if Ineffective_Inline_Warnings
then
1324 Error_Msg_NE
(Msg
& "p?", N
, Subp
);
1330 --------------------------------------
1331 -- Can_Be_Inlined_In_GNATprove_Mode --
1332 --------------------------------------
1334 function Can_Be_Inlined_In_GNATprove_Mode
1335 (Spec_Id
: Entity_Id
;
1336 Body_Id
: Entity_Id
) return Boolean
1338 function Has_Formal_With_Discriminant_Dependent_Fields
1339 (Id
: Entity_Id
) return Boolean;
1340 -- Returns true if the subprogram has at least one formal parameter of
1341 -- an unconstrained record type with per-object constraints on component
1344 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1345 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1348 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1349 -- Returns True if subprogram Id defines a compilation unit
1350 -- Shouldn't this be in Sem_Aux???
1352 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean;
1353 -- Returns True if subprogram Id is defined in the visible part of a
1354 -- package specification.
1356 function Is_Expression_Function
(Id
: Entity_Id
) return Boolean;
1357 -- Returns True if subprogram Id was defined originally as an expression
1360 ---------------------------------------------------
1361 -- Has_Formal_With_Discriminant_Dependent_Fields --
1362 ---------------------------------------------------
1364 function Has_Formal_With_Discriminant_Dependent_Fields
1365 (Id
: Entity_Id
) return Boolean is
1367 function Has_Discriminant_Dependent_Component
1368 (Typ
: Entity_Id
) return Boolean;
1369 -- Determine whether unconstrained record type Typ has at least
1370 -- one component that depends on a discriminant.
1372 ------------------------------------------
1373 -- Has_Discriminant_Dependent_Component --
1374 ------------------------------------------
1376 function Has_Discriminant_Dependent_Component
1377 (Typ
: Entity_Id
) return Boolean
1382 -- Inspect all components of the record type looking for one
1383 -- that depends on a discriminant.
1385 Comp
:= First_Component
(Typ
);
1386 while Present
(Comp
) loop
1387 if Has_Discriminant_Dependent_Constraint
(Comp
) then
1391 Next_Component
(Comp
);
1395 end Has_Discriminant_Dependent_Component
;
1399 Subp_Id
: constant Entity_Id
:= Ultimate_Alias
(Id
);
1401 Formal_Typ
: Entity_Id
;
1403 -- Start of processing for
1404 -- Has_Formal_With_Discriminant_Dependent_Component
1407 -- Inspect all parameters of the subprogram looking for a formal
1408 -- of an unconstrained record type with at least one discriminant
1409 -- dependent component.
1411 Formal
:= First_Formal
(Subp_Id
);
1412 while Present
(Formal
) loop
1413 Formal_Typ
:= Etype
(Formal
);
1415 if Is_Record_Type
(Formal_Typ
)
1416 and then not Is_Constrained
(Formal_Typ
)
1417 and then Has_Discriminant_Dependent_Component
(Formal_Typ
)
1422 Next_Formal
(Formal
);
1426 end Has_Formal_With_Discriminant_Dependent_Fields
;
1428 -----------------------
1429 -- Has_Some_Contract --
1430 -----------------------
1432 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean is
1436 -- A call to an expression function may precede the actual body which
1437 -- is inserted at the end of the enclosing declarations. Ensure that
1438 -- the related entity is decorated before inspecting the contract.
1440 if Is_Subprogram_Or_Generic_Subprogram
(Id
) then
1441 Items
:= Contract
(Id
);
1443 return Present
(Items
)
1444 and then (Present
(Pre_Post_Conditions
(Items
)) or else
1445 Present
(Contract_Test_Cases
(Items
)) or else
1446 Present
(Classifications
(Items
)));
1450 end Has_Some_Contract
;
1452 -----------------------------
1453 -- In_Package_Visible_Spec --
1454 -----------------------------
1456 function In_Package_Visible_Spec
(Id
: Node_Id
) return Boolean is
1457 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1461 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1462 Decl
:= Parent
(Decl
);
1467 return Nkind
(P
) = N_Package_Specification
1468 and then List_Containing
(Decl
) = Visible_Declarations
(P
);
1469 end In_Package_Visible_Spec
;
1471 ----------------------------
1472 -- Is_Expression_Function --
1473 ----------------------------
1475 function Is_Expression_Function
(Id
: Entity_Id
) return Boolean is
1476 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1478 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1479 Decl
:= Parent
(Decl
);
1482 return Nkind
(Original_Node
(Decl
)) = N_Expression_Function
;
1483 end Is_Expression_Function
;
1485 ------------------------
1486 -- Is_Unit_Subprogram --
1487 ------------------------
1489 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean is
1490 Decl
: Node_Id
:= Parent
(Parent
(Id
));
1492 if Nkind
(Parent
(Id
)) = N_Defining_Program_Unit_Name
then
1493 Decl
:= Parent
(Decl
);
1496 return Nkind
(Parent
(Decl
)) = N_Compilation_Unit
;
1497 end Is_Unit_Subprogram
;
1499 -- Local declarations
1501 Id
: Entity_Id
; -- Procedure or function entity for the subprogram
1503 -- Start of Can_Be_Inlined_In_GNATprove_Mode
1506 pragma Assert
(Present
(Spec_Id
) or else Present
(Body_Id
));
1508 if Present
(Spec_Id
) then
1514 -- Only local subprograms without contracts are inlined in GNATprove
1515 -- mode, as these are the subprograms which a user is not interested in
1516 -- analyzing in isolation, but rather in the context of their call. This
1517 -- is a convenient convention, that could be changed for an explicit
1518 -- pragma/aspect one day.
1520 -- In a number of special cases, inlining is not desirable or not
1521 -- possible, see below.
1523 -- Do not inline unit-level subprograms
1525 if Is_Unit_Subprogram
(Id
) then
1528 -- Do not inline subprograms declared in the visible part of a package
1530 elsif In_Package_Visible_Spec
(Id
) then
1533 -- Do not inline subprograms that have a contract on the spec or the
1534 -- body. Use the contract(s) instead in GNATprove.
1536 elsif (Present
(Spec_Id
) and then Has_Some_Contract
(Spec_Id
))
1538 (Present
(Body_Id
) and then Has_Some_Contract
(Body_Id
))
1542 -- Do not inline expression functions, which are directly inlined at the
1545 elsif (Present
(Spec_Id
) and then Is_Expression_Function
(Spec_Id
))
1547 (Present
(Body_Id
) and then Is_Expression_Function
(Body_Id
))
1551 -- Do not inline generic subprogram instances. The visibility rules of
1552 -- generic instances plays badly with inlining.
1554 elsif Is_Generic_Instance
(Spec_Id
) then
1557 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1558 -- the subprogram body, a similar check is performed after the body
1559 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1561 elsif Present
(Spec_Id
)
1563 (No
(SPARK_Pragma
(Spec_Id
))
1564 or else Get_SPARK_Mode_From_Pragma
(SPARK_Pragma
(Spec_Id
)) /= On
)
1568 -- Subprograms in generic instances are currently not inlined, to avoid
1569 -- problems with inlining of standard library subprograms.
1571 elsif Instantiation_Location
(Sloc
(Id
)) /= No_Location
then
1574 -- Do not inline predicate functions (treated specially by GNATprove)
1576 elsif Is_Predicate_Function
(Id
) then
1579 -- Do not inline subprograms with a parameter of an unconstrained
1580 -- record type if it has discrimiant dependent fields. Indeed, with
1581 -- such parameters, the frontend cannot always ensure type compliance
1582 -- in record component accesses (in particular with records containing
1585 elsif Has_Formal_With_Discriminant_Dependent_Fields
(Id
) then
1588 -- Otherwise, this is a subprogram declared inside the private part of a
1589 -- package, or inside a package body, or locally in a subprogram, and it
1590 -- does not have any contract. Inline it.
1595 end Can_Be_Inlined_In_GNATprove_Mode
;
1597 --------------------------------------------
1598 -- Check_And_Split_Unconstrained_Function --
1599 --------------------------------------------
1601 procedure Check_And_Split_Unconstrained_Function
1603 Spec_Id
: Entity_Id
;
1604 Body_Id
: Entity_Id
)
1606 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
);
1607 -- Use generic machinery to build an unexpanded body for the subprogram.
1608 -- This body is subsequently used for inline expansions at call sites.
1610 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean;
1611 -- Return true if we generate code for the function body N, the function
1612 -- body N has no local declarations and its unique statement is a single
1613 -- extended return statement with a handled statements sequence.
1615 procedure Generate_Subprogram_Body
1617 Body_To_Inline
: out Node_Id
);
1618 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1619 -- of pragmas referencing the formals are removed since they have no
1620 -- meaning when the body is inlined and the formals are rewritten (the
1621 -- analysis of the non-inlined body will handle these pragmas properly).
1622 -- A new internal name is associated with Body_To_Inline.
1624 procedure Split_Unconstrained_Function
1626 Spec_Id
: Entity_Id
);
1627 -- N is an inlined function body that returns an unconstrained type and
1628 -- has a single extended return statement. Split N in two subprograms:
1629 -- a procedure P' and a function F'. The formals of P' duplicate the
1630 -- formals of N plus an extra formal which is used return a value;
1631 -- its body is composed by the declarations and list of statements
1632 -- of the extended return statement of N.
1634 --------------------------
1635 -- Build_Body_To_Inline --
1636 --------------------------
1638 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1639 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1640 Original_Body
: Node_Id
;
1641 Body_To_Analyze
: Node_Id
;
1644 pragma Assert
(Current_Scope
= Spec_Id
);
1646 -- Within an instance, the body to inline must be treated as a nested
1647 -- generic, so that the proper global references are preserved. We
1648 -- do not do this at the library level, because it is not needed, and
1649 -- furthermore this causes trouble if front end inlining is activated
1653 and then Scope
(Current_Scope
) /= Standard_Standard
1655 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1658 -- We need to capture references to the formals in order
1659 -- to substitute the actuals at the point of inlining, i.e.
1660 -- instantiation. To treat the formals as globals to the body to
1661 -- inline, we nest it within a dummy parameterless subprogram,
1662 -- declared within the real one.
1664 Generate_Subprogram_Body
(N
, Original_Body
);
1665 Body_To_Analyze
:= Copy_Generic_Node
(Original_Body
, Empty
, False);
1667 -- Set return type of function, which is also global and does not
1668 -- need to be resolved.
1670 if Ekind
(Spec_Id
) = E_Function
then
1671 Set_Result_Definition
(Specification
(Body_To_Analyze
),
1672 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1675 if No
(Declarations
(N
)) then
1676 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1678 Append_To
(Declarations
(N
), Body_To_Analyze
);
1681 Preanalyze
(Body_To_Analyze
);
1683 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1684 Save_Global_References
(Original_Body
);
1686 Remove
(Body_To_Analyze
);
1688 -- Restore environment if previously saved
1691 and then Scope
(Current_Scope
) /= Standard_Standard
1696 pragma Assert
(No
(Body_To_Inline
(Decl
)));
1697 Set_Body_To_Inline
(Decl
, Original_Body
);
1698 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1699 end Build_Body_To_Inline
;
1701 --------------------------------------
1702 -- Can_Split_Unconstrained_Function --
1703 --------------------------------------
1705 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean
1707 Ret_Node
: constant Node_Id
:=
1708 First
(Statements
(Handled_Statement_Sequence
(N
)));
1712 -- No user defined declarations allowed in the function except inside
1713 -- the unique return statement; implicit labels are the only allowed
1716 if not Is_Empty_List
(Declarations
(N
)) then
1717 D
:= First
(Declarations
(N
));
1718 while Present
(D
) loop
1719 if Nkind
(D
) /= N_Implicit_Label_Declaration
then
1727 -- We only split the inlined function when we are generating the code
1728 -- of its body; otherwise we leave duplicated split subprograms in
1729 -- the tree which (if referenced) generate wrong references at link
1732 return In_Extended_Main_Code_Unit
(N
)
1733 and then Present
(Ret_Node
)
1734 and then Nkind
(Ret_Node
) = N_Extended_Return_Statement
1735 and then No
(Next
(Ret_Node
))
1736 and then Present
(Handled_Statement_Sequence
(Ret_Node
));
1737 end Can_Split_Unconstrained_Function
;
1739 -----------------------------
1740 -- Generate_Body_To_Inline --
1741 -----------------------------
1743 procedure Generate_Subprogram_Body
1745 Body_To_Inline
: out Node_Id
)
1748 -- Within an instance, the body to inline must be treated as a nested
1749 -- generic, so that the proper global references are preserved.
1751 -- Note that we do not do this at the library level, because it
1752 -- is not needed, and furthermore this causes trouble if front
1753 -- end inlining is activated (-gnatN).
1756 and then Scope
(Current_Scope
) /= Standard_Standard
1758 Body_To_Inline
:= Copy_Generic_Node
(N
, Empty
, True);
1760 Body_To_Inline
:= Copy_Separate_Tree
(N
);
1763 -- Remove all aspects/pragmas that have no meaning in an inlined body
1765 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
1767 -- We need to capture references to the formals in order
1768 -- to substitute the actuals at the point of inlining, i.e.
1769 -- instantiation. To treat the formals as globals to the body to
1770 -- inline, we nest it within a dummy parameterless subprogram,
1771 -- declared within the real one.
1773 Set_Parameter_Specifications
1774 (Specification
(Body_To_Inline
), No_List
);
1776 -- A new internal name is associated with Body_To_Inline to avoid
1777 -- conflicts when the non-inlined body N is analyzed.
1779 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
1780 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
1781 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
1782 end Generate_Subprogram_Body
;
1784 ----------------------------------
1785 -- Split_Unconstrained_Function --
1786 ----------------------------------
1788 procedure Split_Unconstrained_Function
1790 Spec_Id
: Entity_Id
)
1792 Loc
: constant Source_Ptr
:= Sloc
(N
);
1793 Ret_Node
: constant Node_Id
:=
1794 First
(Statements
(Handled_Statement_Sequence
(N
)));
1795 Ret_Obj
: constant Node_Id
:=
1796 First
(Return_Object_Declarations
(Ret_Node
));
1798 procedure Build_Procedure
1799 (Proc_Id
: out Entity_Id
;
1800 Decl_List
: out List_Id
);
1801 -- Build a procedure containing the statements found in the extended
1802 -- return statement of the unconstrained function body N.
1804 ---------------------
1805 -- Build_Procedure --
1806 ---------------------
1808 procedure Build_Procedure
1809 (Proc_Id
: out Entity_Id
;
1810 Decl_List
: out List_Id
)
1813 Formal_List
: constant List_Id
:= New_List
;
1814 Proc_Spec
: Node_Id
;
1815 Proc_Body
: Node_Id
;
1816 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
1817 Body_Decl_List
: List_Id
:= No_List
;
1818 Param_Type
: Node_Id
;
1821 if Nkind
(Object_Definition
(Ret_Obj
)) = N_Identifier
then
1823 New_Copy
(Object_Definition
(Ret_Obj
));
1826 New_Copy
(Subtype_Mark
(Object_Definition
(Ret_Obj
)));
1829 Append_To
(Formal_List
,
1830 Make_Parameter_Specification
(Loc
,
1831 Defining_Identifier
=>
1832 Make_Defining_Identifier
(Loc
,
1833 Chars
=> Chars
(Defining_Identifier
(Ret_Obj
))),
1834 In_Present
=> False,
1835 Out_Present
=> True,
1836 Null_Exclusion_Present
=> False,
1837 Parameter_Type
=> Param_Type
));
1839 Formal
:= First_Formal
(Spec_Id
);
1841 -- Note that we copy the parameter type rather than creating
1842 -- a reference to it, because it may be a class-wide entity
1843 -- that will not be retrieved by name.
1845 while Present
(Formal
) loop
1846 Append_To
(Formal_List
,
1847 Make_Parameter_Specification
(Loc
,
1848 Defining_Identifier
=>
1849 Make_Defining_Identifier
(Sloc
(Formal
),
1850 Chars
=> Chars
(Formal
)),
1851 In_Present
=> In_Present
(Parent
(Formal
)),
1852 Out_Present
=> Out_Present
(Parent
(Formal
)),
1853 Null_Exclusion_Present
=>
1854 Null_Exclusion_Present
(Parent
(Formal
)),
1856 New_Copy_Tree
(Parameter_Type
(Parent
(Formal
))),
1858 Copy_Separate_Tree
(Expression
(Parent
(Formal
)))));
1860 Next_Formal
(Formal
);
1863 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
1866 Make_Procedure_Specification
(Loc
,
1867 Defining_Unit_Name
=> Proc_Id
,
1868 Parameter_Specifications
=> Formal_List
);
1870 Decl_List
:= New_List
;
1872 Append_To
(Decl_List
,
1873 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
1875 -- Can_Convert_Unconstrained_Function checked that the function
1876 -- has no local declarations except implicit label declarations.
1877 -- Copy these declarations to the built procedure.
1879 if Present
(Declarations
(N
)) then
1880 Body_Decl_List
:= New_List
;
1887 D
:= First
(Declarations
(N
));
1888 while Present
(D
) loop
1889 pragma Assert
(Nkind
(D
) = N_Implicit_Label_Declaration
);
1892 Make_Implicit_Label_Declaration
(Loc
,
1893 Make_Defining_Identifier
(Loc
,
1894 Chars
=> Chars
(Defining_Identifier
(D
))),
1895 Label_Construct
=> Empty
);
1896 Append_To
(Body_Decl_List
, New_D
);
1903 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Node
)));
1906 Make_Subprogram_Body
(Loc
,
1907 Specification
=> Copy_Separate_Tree
(Proc_Spec
),
1908 Declarations
=> Body_Decl_List
,
1909 Handled_Statement_Sequence
=>
1910 Copy_Separate_Tree
(Handled_Statement_Sequence
(Ret_Node
)));
1912 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
1913 Make_Defining_Identifier
(Loc
, Subp_Name
));
1915 Append_To
(Decl_List
, Proc_Body
);
1916 end Build_Procedure
;
1920 New_Obj
: constant Node_Id
:= Copy_Separate_Tree
(Ret_Obj
);
1922 Proc_Id
: Entity_Id
;
1923 Proc_Call
: Node_Id
;
1925 -- Start of processing for Split_Unconstrained_Function
1928 -- Build the associated procedure, analyze it and insert it before
1929 -- the function body N.
1932 Scope
: constant Entity_Id
:= Current_Scope
;
1933 Decl_List
: List_Id
;
1936 Build_Procedure
(Proc_Id
, Decl_List
);
1937 Insert_Actions
(N
, Decl_List
);
1941 -- Build the call to the generated procedure
1944 Actual_List
: constant List_Id
:= New_List
;
1948 Append_To
(Actual_List
,
1949 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
1951 Formal
:= First_Formal
(Spec_Id
);
1952 while Present
(Formal
) loop
1953 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
1955 -- Avoid spurious warning on unreferenced formals
1957 Set_Referenced
(Formal
);
1958 Next_Formal
(Formal
);
1962 Make_Procedure_Call_Statement
(Loc
,
1963 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
1964 Parameter_Associations
=> Actual_List
);
1972 -- main_1__F1b (New_Obj, ...);
1977 Make_Block_Statement
(Loc
,
1978 Declarations
=> New_List
(New_Obj
),
1979 Handled_Statement_Sequence
=>
1980 Make_Handled_Sequence_Of_Statements
(Loc
,
1981 Statements
=> New_List
(
1985 Make_Simple_Return_Statement
(Loc
,
1988 (Defining_Identifier
(New_Obj
), Loc
)))));
1990 Rewrite
(Ret_Node
, Blk_Stmt
);
1991 end Split_Unconstrained_Function
;
1995 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1997 -- Start of processing for Check_And_Split_Unconstrained_Function
2000 pragma Assert
(Back_End_Inlining
2001 and then Ekind
(Spec_Id
) = E_Function
2002 and then Returns_Unconstrained_Type
(Spec_Id
)
2003 and then Comes_From_Source
(Body_Id
)
2004 and then (Has_Pragma_Inline_Always
(Spec_Id
)
2005 or else Optimization_Level
> 0));
2007 -- This routine must not be used in GNATprove mode since GNATprove
2008 -- relies on frontend inlining
2010 pragma Assert
(not GNATprove_Mode
);
2012 -- No need to split the function if we cannot generate the code
2014 if Serious_Errors_Detected
/= 0 then
2018 -- No action needed in stubs since the attribute Body_To_Inline
2021 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
2024 -- Cannot build the body to inline if the attribute is already set.
2025 -- This attribute may have been set if this is a subprogram renaming
2026 -- declarations (see Freeze.Build_Renamed_Body).
2028 elsif Present
(Body_To_Inline
(Decl
)) then
2031 -- Check excluded declarations
2033 elsif Present
(Declarations
(N
))
2034 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
2038 -- Check excluded statements. There is no need to protect us against
2039 -- exception handlers since they are supported by the GCC backend.
2041 elsif Present
(Handled_Statement_Sequence
(N
))
2042 and then Has_Excluded_Statement
2043 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2048 -- Build the body to inline only if really needed
2050 if Can_Split_Unconstrained_Function
(N
) then
2051 Split_Unconstrained_Function
(N
, Spec_Id
);
2052 Build_Body_To_Inline
(N
, Spec_Id
);
2053 Set_Is_Inlined
(Spec_Id
);
2055 end Check_And_Split_Unconstrained_Function
;
2057 -------------------------------------
2058 -- Check_Package_Body_For_Inlining --
2059 -------------------------------------
2061 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2062 Bname
: Unit_Name_Type
;
2067 -- Legacy implementation (relying on frontend inlining)
2069 if not Back_End_Inlining
2070 and then Is_Compilation_Unit
(P
)
2071 and then not Is_Generic_Instance
(P
)
2073 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2075 E
:= First_Entity
(P
);
2076 while Present
(E
) loop
2077 if Has_Pragma_Inline_Always
(E
)
2078 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2080 if not Is_Loaded
(Bname
) then
2081 Load_Needed_Body
(N
, OK
);
2085 -- Check we are not trying to inline a parent whose body
2086 -- depends on a child, when we are compiling the body of
2087 -- the child. Otherwise we have a potential elaboration
2088 -- circularity with inlined subprograms and with
2089 -- Taft-Amendment types.
2092 Comp
: Node_Id
; -- Body just compiled
2093 Child_Spec
: Entity_Id
; -- Spec of main unit
2094 Ent
: Entity_Id
; -- For iteration
2095 With_Clause
: Node_Id
; -- Context of body.
2098 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2099 and then Present
(Body_Entity
(P
))
2103 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2106 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2108 -- Check whether the context of the body just
2109 -- compiled includes a child of itself, and that
2110 -- child is the spec of the main compilation.
2112 With_Clause
:= First
(Context_Items
(Comp
));
2113 while Present
(With_Clause
) loop
2114 if Nkind
(With_Clause
) = N_With_Clause
2116 Scope
(Entity
(Name
(With_Clause
))) = P
2118 Entity
(Name
(With_Clause
)) = Child_Spec
2120 Error_Msg_Node_2
:= Child_Spec
;
2122 ("body of & depends on child unit&??",
2125 ("\subprograms in body cannot be inlined??",
2128 -- Disable further inlining from this unit,
2129 -- and keep Taft-amendment types incomplete.
2131 Ent
:= First_Entity
(P
);
2132 while Present
(Ent
) loop
2134 and then Has_Completion_In_Body
(Ent
)
2136 Set_Full_View
(Ent
, Empty
);
2138 elsif Is_Subprogram
(Ent
) then
2139 Set_Is_Inlined
(Ent
, False);
2153 elsif Ineffective_Inline_Warnings
then
2154 Error_Msg_Unit_1
:= Bname
;
2156 ("unable to inline subprograms defined in $??", P
);
2157 Error_Msg_N
("\body not found??", P
);
2168 end Check_Package_Body_For_Inlining
;
2170 --------------------
2171 -- Cleanup_Scopes --
2172 --------------------
2174 procedure Cleanup_Scopes
is
2180 Elmt
:= First_Elmt
(To_Clean
);
2181 while Present
(Elmt
) loop
2182 Scop
:= Node
(Elmt
);
2184 if Ekind
(Scop
) = E_Entry
then
2185 Scop
:= Protected_Body_Subprogram
(Scop
);
2187 elsif Is_Subprogram
(Scop
)
2188 and then Is_Protected_Type
(Scope
(Scop
))
2189 and then Present
(Protected_Body_Subprogram
(Scop
))
2191 -- If a protected operation contains an instance, its cleanup
2192 -- operations have been delayed, and the subprogram has been
2193 -- rewritten in the expansion of the enclosing protected body. It
2194 -- is the corresponding subprogram that may require the cleanup
2195 -- operations, so propagate the information that triggers cleanup
2199 (Protected_Body_Subprogram
(Scop
),
2200 Uses_Sec_Stack
(Scop
));
2202 Scop
:= Protected_Body_Subprogram
(Scop
);
2205 if Ekind
(Scop
) = E_Block
then
2206 Decl
:= Parent
(Block_Node
(Scop
));
2209 Decl
:= Unit_Declaration_Node
(Scop
);
2211 if Nkind_In
(Decl
, N_Subprogram_Declaration
,
2212 N_Task_Type_Declaration
,
2213 N_Subprogram_Body_Stub
)
2215 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2220 Expand_Cleanup_Actions
(Decl
);
2223 Elmt
:= Next_Elmt
(Elmt
);
2227 -------------------------
2228 -- Expand_Inlined_Call --
2229 -------------------------
2231 procedure Expand_Inlined_Call
2234 Orig_Subp
: Entity_Id
)
2236 Loc
: constant Source_Ptr
:= Sloc
(N
);
2237 Is_Predef
: constant Boolean :=
2238 Is_Predefined_File_Name
2239 (Unit_File_Name
(Get_Source_Unit
(Subp
)));
2240 Orig_Bod
: constant Node_Id
:=
2241 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2245 Decls
: constant List_Id
:= New_List
;
2246 Exit_Lab
: Entity_Id
:= Empty
;
2253 Ret_Type
: Entity_Id
;
2256 -- The target of the call. If context is an assignment statement then
2257 -- this is the left-hand side of the assignment, else it is a temporary
2258 -- to which the return value is assigned prior to rewriting the call.
2261 -- A separate target used when the return type is unconstrained
2264 Temp_Typ
: Entity_Id
;
2266 Return_Object
: Entity_Id
:= Empty
;
2267 -- Entity in declaration in an extended_return_statement
2270 Is_Unc_Decl
: Boolean;
2271 -- If the type returned by the function is unconstrained and the call
2272 -- can be inlined, special processing is required.
2274 procedure Make_Exit_Label
;
2275 -- Build declaration for exit label to be used in Return statements,
2276 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2277 -- declaration). Does nothing if Exit_Lab already set.
2279 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2280 -- Replace occurrence of a formal with the corresponding actual, or the
2281 -- thunk generated for it. Replace a return statement with an assignment
2282 -- to the target of the call, with appropriate conversions if needed.
2284 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2285 -- If the call being expanded is that of an internal subprogram, set the
2286 -- sloc of the generated block to that of the call itself, so that the
2287 -- expansion is skipped by the "next" command in gdb. Same processing
2288 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2289 -- Debug_Generated_Code is true, suppress this change to simplify our
2290 -- own development. Same in GNATprove mode, to ensure that warnings and
2291 -- diagnostics point to the proper location.
2293 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
2294 -- In subtree N search for occurrences of dispatching calls that use the
2295 -- Ada 2005 Object.Operation notation and the object is a formal of the
2296 -- inlined subprogram. Reset the entity associated with Operation in all
2297 -- the found occurrences.
2299 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2300 -- If the function body is a single expression, replace call with
2301 -- expression, else insert block appropriately.
2303 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2304 -- If procedure body has no local variables, inline body without
2305 -- creating block, otherwise rewrite call with block.
2307 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2308 -- Determine whether a formal parameter is used only once in Orig_Bod
2310 ---------------------
2311 -- Make_Exit_Label --
2312 ---------------------
2314 procedure Make_Exit_Label
is
2315 Lab_Ent
: Entity_Id
;
2317 if No
(Exit_Lab
) then
2318 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
2319 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
2320 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2322 Make_Implicit_Label_Declaration
(Loc
,
2323 Defining_Identifier
=> Lab_Ent
,
2324 Label_Construct
=> Exit_Lab
);
2326 end Make_Exit_Label
;
2328 ---------------------
2329 -- Process_Formals --
2330 ---------------------
2332 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
2338 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
2341 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
2342 A
:= Renamed_Object
(E
);
2344 -- Rewrite the occurrence of the formal into an occurrence of
2345 -- the actual. Also establish visibility on the proper view of
2346 -- the actual's subtype for the body's context (if the actual's
2347 -- subtype is private at the call point but its full view is
2348 -- visible to the body, then the inlined tree here must be
2349 -- analyzed with the full view).
2351 if Is_Entity_Name
(A
) then
2352 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
2353 Check_Private_View
(N
);
2355 elsif Nkind
(A
) = N_Defining_Identifier
then
2356 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
2357 Check_Private_View
(N
);
2362 Rewrite
(N
, New_Copy
(A
));
2368 elsif Is_Entity_Name
(N
)
2369 and then Present
(Return_Object
)
2370 and then Chars
(N
) = Chars
(Return_Object
)
2372 -- Occurrence within an extended return statement. The return
2373 -- object is local to the body been inlined, and thus the generic
2374 -- copy is not analyzed yet, so we match by name, and replace it
2375 -- with target of call.
2377 if Nkind
(Targ
) = N_Defining_Identifier
then
2378 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
2380 Rewrite
(N
, New_Copy_Tree
(Targ
));
2385 elsif Nkind
(N
) = N_Simple_Return_Statement
then
2386 if No
(Expression
(N
)) then
2389 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2392 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
2393 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
2395 -- Function body is a single expression. No need for
2401 Num_Ret
:= Num_Ret
+ 1;
2405 -- Because of the presence of private types, the views of the
2406 -- expression and the context may be different, so place an
2407 -- unchecked conversion to the context type to avoid spurious
2408 -- errors, e.g. when the expression is a numeric literal and
2409 -- the context is private. If the expression is an aggregate,
2410 -- use a qualified expression, because an aggregate is not a
2411 -- legal argument of a conversion. Ditto for numeric literals,
2412 -- which must be resolved to a specific type.
2414 if Nkind_In
(Expression
(N
), N_Aggregate
,
2420 Make_Qualified_Expression
(Sloc
(N
),
2421 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
2422 Expression
=> Relocate_Node
(Expression
(N
)));
2425 Unchecked_Convert_To
2426 (Ret_Type
, Relocate_Node
(Expression
(N
)));
2429 if Nkind
(Targ
) = N_Defining_Identifier
then
2431 Make_Assignment_Statement
(Loc
,
2432 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2433 Expression
=> Ret
));
2436 Make_Assignment_Statement
(Loc
,
2437 Name
=> New_Copy
(Targ
),
2438 Expression
=> Ret
));
2441 Set_Assignment_OK
(Name
(N
));
2443 if Present
(Exit_Lab
) then
2445 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
2451 -- An extended return becomes a block whose first statement is the
2452 -- assignment of the initial expression of the return object to the
2453 -- target of the call itself.
2455 elsif Nkind
(N
) = N_Extended_Return_Statement
then
2457 Return_Decl
: constant Entity_Id
:=
2458 First
(Return_Object_Declarations
(N
));
2462 Return_Object
:= Defining_Identifier
(Return_Decl
);
2464 if Present
(Expression
(Return_Decl
)) then
2465 if Nkind
(Targ
) = N_Defining_Identifier
then
2467 Make_Assignment_Statement
(Loc
,
2468 Name
=> New_Occurrence_Of
(Targ
, Loc
),
2469 Expression
=> Expression
(Return_Decl
));
2472 Make_Assignment_Statement
(Loc
,
2473 Name
=> New_Copy
(Targ
),
2474 Expression
=> Expression
(Return_Decl
));
2477 Set_Assignment_OK
(Name
(Assign
));
2479 if No
(Handled_Statement_Sequence
(N
)) then
2480 Set_Handled_Statement_Sequence
(N
,
2481 Make_Handled_Sequence_Of_Statements
(Loc
,
2482 Statements
=> New_List
));
2486 Statements
(Handled_Statement_Sequence
(N
)));
2490 Make_Block_Statement
(Loc
,
2491 Handled_Statement_Sequence
=>
2492 Handled_Statement_Sequence
(N
)));
2497 -- Remove pragma Unreferenced since it may refer to formals that
2498 -- are not visible in the inlined body, and in any case we will
2499 -- not be posting warnings on the inlined body so it is unneeded.
2501 elsif Nkind
(N
) = N_Pragma
2502 and then Pragma_Name
(N
) = Name_Unreferenced
2504 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
2510 end Process_Formals
;
2512 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
2518 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
2520 if not Debug_Generated_Code
then
2521 Set_Sloc
(Nod
, Sloc
(N
));
2522 Set_Comes_From_Source
(Nod
, False);
2528 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
2530 ------------------------------
2531 -- Reset_Dispatching_Calls --
2532 ------------------------------
2534 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
2536 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
2537 -- Comment required ???
2543 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
2545 if Nkind
(N
) = N_Procedure_Call_Statement
2546 and then Nkind
(Name
(N
)) = N_Selected_Component
2547 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
2548 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
2549 and then Is_Dispatching_Operation
2550 (Entity
(Selector_Name
(Name
(N
))))
2552 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
2558 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
2562 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
2563 pragma Unreferenced
(Dummy
);
2565 -- Start of processing for Reset_Dispatching_Calls
2569 end Reset_Dispatching_Calls
;
2571 ---------------------------
2572 -- Rewrite_Function_Call --
2573 ---------------------------
2575 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2576 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2577 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
2580 -- Optimize simple case: function body is a single return statement,
2581 -- which has been expanded into an assignment.
2583 if Is_Empty_List
(Declarations
(Blk
))
2584 and then Nkind
(Fst
) = N_Assignment_Statement
2585 and then No
(Next
(Fst
))
2587 -- The function call may have been rewritten as the temporary
2588 -- that holds the result of the call, in which case remove the
2589 -- now useless declaration.
2591 if Nkind
(N
) = N_Identifier
2592 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2594 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
2597 Rewrite
(N
, Expression
(Fst
));
2599 elsif Nkind
(N
) = N_Identifier
2600 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
2602 -- The block assigns the result of the call to the temporary
2604 Insert_After
(Parent
(Entity
(N
)), Blk
);
2606 -- If the context is an assignment, and the left-hand side is free of
2607 -- side-effects, the replacement is also safe.
2608 -- Can this be generalized further???
2610 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
2612 (Is_Entity_Name
(Name
(Parent
(N
)))
2614 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
2615 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
2618 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
2619 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
2621 -- Replace assignment with the block
2624 Original_Assignment
: constant Node_Id
:= Parent
(N
);
2627 -- Preserve the original assignment node to keep the complete
2628 -- assignment subtree consistent enough for Analyze_Assignment
2629 -- to proceed (specifically, the original Lhs node must still
2630 -- have an assignment statement as its parent).
2632 -- We cannot rely on Original_Node to go back from the block
2633 -- node to the assignment node, because the assignment might
2634 -- already be a rewrite substitution.
2636 Discard_Node
(Relocate_Node
(Original_Assignment
));
2637 Rewrite
(Original_Assignment
, Blk
);
2640 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
2642 -- A call to a function which returns an unconstrained type
2643 -- found in the expression initializing an object-declaration is
2644 -- expanded into a procedure call which must be added after the
2645 -- object declaration.
2647 if Is_Unc_Decl
and Back_End_Inlining
then
2648 Insert_Action_After
(Parent
(N
), Blk
);
2650 Set_Expression
(Parent
(N
), Empty
);
2651 Insert_After
(Parent
(N
), Blk
);
2654 elsif Is_Unc
and then not Back_End_Inlining
then
2655 Insert_Before
(Parent
(N
), Blk
);
2657 end Rewrite_Function_Call
;
2659 ----------------------------
2660 -- Rewrite_Procedure_Call --
2661 ----------------------------
2663 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
2664 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
2667 -- If there is a transient scope for N, this will be the scope of the
2668 -- actions for N, and the statements in Blk need to be within this
2669 -- scope. For example, they need to have visibility on the constant
2670 -- declarations created for the formals.
2672 -- If N needs no transient scope, and if there are no declarations in
2673 -- the inlined body, we can do a little optimization and insert the
2674 -- statements for the body directly after N, and rewrite N to a
2675 -- null statement, instead of rewriting N into a full-blown block
2678 if not Scope_Is_Transient
2679 and then Is_Empty_List
(Declarations
(Blk
))
2681 Insert_List_After
(N
, Statements
(HSS
));
2682 Rewrite
(N
, Make_Null_Statement
(Loc
));
2686 end Rewrite_Procedure_Call
;
2688 -------------------------
2689 -- Formal_Is_Used_Once --
2690 -------------------------
2692 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2693 Use_Counter
: Int
:= 0;
2695 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2696 -- Traverse the tree and count the uses of the formal parameter.
2697 -- In this case, for optimization purposes, we do not need to
2698 -- continue the traversal once more than one use is encountered.
2704 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2706 -- The original node is an identifier
2708 if Nkind
(N
) = N_Identifier
2709 and then Present
(Entity
(N
))
2711 -- Original node's entity points to the one in the copied body
2713 and then Nkind
(Entity
(N
)) = N_Identifier
2714 and then Present
(Entity
(Entity
(N
)))
2716 -- The entity of the copied node is the formal parameter
2718 and then Entity
(Entity
(N
)) = Formal
2720 Use_Counter
:= Use_Counter
+ 1;
2722 if Use_Counter
> 1 then
2724 -- Denote more than one use and abandon the traversal
2735 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2737 -- Start of processing for Formal_Is_Used_Once
2740 Count_Formal_Uses
(Orig_Bod
);
2741 return Use_Counter
= 1;
2742 end Formal_Is_Used_Once
;
2744 -- Start of processing for Expand_Inlined_Call
2747 -- Initializations for old/new semantics
2749 if not Back_End_Inlining
then
2750 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
2751 and then not Is_Constrained
(Etype
(Subp
));
2752 Is_Unc_Decl
:= False;
2754 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
2755 and then Optimization_Level
> 0;
2756 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
2760 -- Check for an illegal attempt to inline a recursive procedure. If the
2761 -- subprogram has parameters this is detected when trying to supply a
2762 -- binding for parameters that already have one. For parameterless
2763 -- subprograms this must be done explicitly.
2765 if In_Open_Scopes
(Subp
) then
2766 Error_Msg_N
("call to recursive subprogram cannot be inlined??", N
);
2767 Set_Is_Inlined
(Subp
, False);
2769 -- In GNATprove mode, issue a warning, and indicate that the
2770 -- subprogram is not always inlined by setting flag Is_Inlined_Always
2773 if GNATprove_Mode
then
2774 Set_Is_Inlined_Always
(Subp
, False);
2779 -- Skip inlining if this is not a true inlining since the attribute
2780 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2781 -- true inlining, Orig_Bod has code rather than being an entity.
2783 elsif Nkind
(Orig_Bod
) in N_Entity
then
2786 -- Skip inlining if the function returns an unconstrained type using
2787 -- an extended return statement since this part of the new inlining
2788 -- model which is not yet supported by the current implementation. ???
2792 Nkind
(First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
))))
2793 = N_Extended_Return_Statement
2794 and then not Back_End_Inlining
2799 if Nkind
(Orig_Bod
) = N_Defining_Identifier
2800 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
2802 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2803 -- can be replaced with calls to the renamed entity directly, because
2804 -- the subprograms are subtype conformant. If the renamed subprogram
2805 -- is an inherited operation, we must redo the expansion because
2806 -- implicit conversions may be needed. Similarly, if the renamed
2807 -- entity is inlined, expand the call for further optimizations.
2809 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
2811 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
2818 -- Register the call in the list of inlined calls
2820 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
2822 -- Use generic machinery to copy body of inlined subprogram, as if it
2823 -- were an instantiation, resetting source locations appropriately, so
2824 -- that nested inlined calls appear in the main unit.
2826 Save_Env
(Subp
, Empty
);
2827 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
2831 if not Back_End_Inlining
then
2836 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2838 Make_Block_Statement
(Loc
,
2839 Declarations
=> Declarations
(Bod
),
2840 Handled_Statement_Sequence
=>
2841 Handled_Statement_Sequence
(Bod
));
2843 if No
(Declarations
(Bod
)) then
2844 Set_Declarations
(Blk
, New_List
);
2847 -- For the unconstrained case, capture the name of the local
2848 -- variable that holds the result. This must be the first
2849 -- declaration in the block, because its bounds cannot depend
2850 -- on local variables. Otherwise there is no way to declare the
2851 -- result outside of the block. Needless to say, in general the
2852 -- bounds will depend on the actuals in the call.
2854 -- If the context is an assignment statement, as is the case
2855 -- for the expansion of an extended return, the left-hand side
2856 -- provides bounds even if the return type is unconstrained.
2860 First_Decl
: Node_Id
;
2863 First_Decl
:= First
(Declarations
(Blk
));
2865 if Nkind
(First_Decl
) /= N_Object_Declaration
then
2869 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2870 Targ1
:= Defining_Identifier
(First_Decl
);
2872 Targ1
:= Name
(Parent
(N
));
2889 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
2891 Make_Block_Statement
(Loc
,
2892 Declarations
=> Declarations
(Bod
),
2893 Handled_Statement_Sequence
=>
2894 Handled_Statement_Sequence
(Bod
));
2896 -- Inline a call to a function that returns an unconstrained type.
2897 -- The semantic analyzer checked that frontend-inlined functions
2898 -- returning unconstrained types have no declarations and have
2899 -- a single extended return statement. As part of its processing
2900 -- the function was split in two subprograms: a procedure P and
2901 -- a function F that has a block with a call to procedure P (see
2902 -- Split_Unconstrained_Function).
2908 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
2912 Blk_Stmt
: constant Node_Id
:=
2913 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
2914 First_Stmt
: constant Node_Id
:=
2915 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
2916 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
2920 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
2921 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
2922 and then No
(Next
(Second_Stmt
)));
2927 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
2928 Empty
, Instantiating
=> True);
2931 -- Capture the name of the local variable that holds the
2932 -- result. This must be the first declaration in the block,
2933 -- because its bounds cannot depend on local variables.
2934 -- Otherwise there is no way to declare the result outside
2935 -- of the block. Needless to say, in general the bounds will
2936 -- depend on the actuals in the call.
2938 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
2939 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
2941 -- If the context is an assignment statement, as is the case
2942 -- for the expansion of an extended return, the left-hand
2943 -- side provides bounds even if the return type is
2947 Targ1
:= Name
(Parent
(N
));
2952 if No
(Declarations
(Bod
)) then
2953 Set_Declarations
(Blk
, New_List
);
2958 -- If this is a derived function, establish the proper return type
2960 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
2961 Ret_Type
:= Etype
(Orig_Subp
);
2963 Ret_Type
:= Etype
(Subp
);
2966 -- Create temporaries for the actuals that are expressions, or that are
2967 -- scalars and require copying to preserve semantics.
2969 F
:= First_Formal
(Subp
);
2970 A
:= First_Actual
(N
);
2971 while Present
(F
) loop
2972 if Present
(Renamed_Object
(F
)) then
2974 -- If expander is active, it is an error to try to inline a
2975 -- recursive program. In GNATprove mode, just indicate that the
2976 -- inlining will not happen, and mark the subprogram as not always
2979 if GNATprove_Mode
then
2981 ("cannot inline call to recursive subprogram?", N
, Subp
);
2982 Set_Is_Inlined_Always
(Subp
, False);
2985 ("cannot inline call to recursive subprogram", N
);
2991 -- Reset Last_Assignment for any parameters of mode out or in out, to
2992 -- prevent spurious warnings about overwriting for assignments to the
2993 -- formal in the inlined code.
2995 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
2996 Set_Last_Assignment
(Entity
(A
), Empty
);
2999 -- If the argument may be a controlling argument in a call within
3000 -- the inlined body, we must preserve its classwide nature to insure
3001 -- that dynamic dispatching take place subsequently. If the formal
3002 -- has a constraint it must be preserved to retain the semantics of
3005 if Is_Class_Wide_Type
(Etype
(F
))
3006 or else (Is_Access_Type
(Etype
(F
))
3007 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3009 Temp_Typ
:= Etype
(F
);
3011 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3012 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3014 Temp_Typ
:= Etype
(F
);
3016 Temp_Typ
:= Etype
(A
);
3019 -- If the actual is a simple name or a literal, no need to
3020 -- create a temporary, object can be used directly.
3022 -- If the actual is a literal and the formal has its address taken,
3023 -- we cannot pass the literal itself as an argument, so its value
3024 -- must be captured in a temporary.
3026 if (Is_Entity_Name
(A
)
3028 (not Is_Scalar_Type
(Etype
(A
))
3029 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
))
3031 -- When the actual is an identifier and the corresponding formal is
3032 -- used only once in the original body, the formal can be substituted
3033 -- directly with the actual parameter.
3035 or else (Nkind
(A
) = N_Identifier
3036 and then Formal_Is_Used_Once
(F
))
3039 (Nkind_In
(A
, N_Real_Literal
,
3041 N_Character_Literal
)
3042 and then not Address_Taken
(F
))
3044 if Etype
(F
) /= Etype
(A
) then
3046 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3048 Set_Renamed_Object
(F
, A
);
3052 Temp
:= Make_Temporary
(Loc
, 'C');
3054 -- If the actual for an in/in-out parameter is a view conversion,
3055 -- make it into an unchecked conversion, given that an untagged
3056 -- type conversion is not a proper object for a renaming.
3058 -- In-out conversions that involve real conversions have already
3059 -- been transformed in Expand_Actuals.
3061 if Nkind
(A
) = N_Type_Conversion
3062 and then Ekind
(F
) /= E_In_Parameter
3065 Make_Unchecked_Type_Conversion
(Loc
,
3066 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3067 Expression
=> Relocate_Node
(Expression
(A
)));
3069 elsif Etype
(F
) /= Etype
(A
) then
3070 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3071 Temp_Typ
:= Etype
(F
);
3074 New_A
:= Relocate_Node
(A
);
3077 Set_Sloc
(New_A
, Sloc
(N
));
3079 -- If the actual has a by-reference type, it cannot be copied,
3080 -- so its value is captured in a renaming declaration. Otherwise
3081 -- declare a local constant initialized with the actual.
3083 -- We also use a renaming declaration for expressions of an array
3084 -- type that is not bit-packed, both for efficiency reasons and to
3085 -- respect the semantics of the call: in most cases the original
3086 -- call will pass the parameter by reference, and thus the inlined
3087 -- code will have the same semantics.
3089 -- Finally, we need a renaming declaration in the case of limited
3090 -- types for which initialization cannot be by copy either.
3092 if Ekind
(F
) = E_In_Parameter
3093 and then not Is_By_Reference_Type
(Etype
(A
))
3094 and then not Is_Limited_Type
(Etype
(A
))
3096 (not Is_Array_Type
(Etype
(A
))
3097 or else not Is_Object_Reference
(A
)
3098 or else Is_Bit_Packed_Array
(Etype
(A
)))
3101 Make_Object_Declaration
(Loc
,
3102 Defining_Identifier
=> Temp
,
3103 Constant_Present
=> True,
3104 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3105 Expression
=> New_A
);
3108 Make_Object_Renaming_Declaration
(Loc
,
3109 Defining_Identifier
=> Temp
,
3110 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3114 Append
(Decl
, Decls
);
3115 Set_Renamed_Object
(F
, Temp
);
3122 -- Establish target of function call. If context is not assignment or
3123 -- declaration, create a temporary as a target. The declaration for the
3124 -- temporary may be subsequently optimized away if the body is a single
3125 -- expression, or if the left-hand side of the assignment is simple
3126 -- enough, i.e. an entity or an explicit dereference of one.
3128 if Ekind
(Subp
) = E_Function
then
3129 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3130 and then Is_Entity_Name
(Name
(Parent
(N
)))
3132 Targ
:= Name
(Parent
(N
));
3134 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3135 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3136 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3138 Targ
:= Name
(Parent
(N
));
3140 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3141 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3142 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3144 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3146 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3147 and then Is_Limited_Type
(Etype
(Subp
))
3149 Targ
:= Defining_Identifier
(Parent
(N
));
3151 -- New semantics: In an object declaration avoid an extra copy
3152 -- of the result of a call to an inlined function that returns
3153 -- an unconstrained type
3155 elsif Back_End_Inlining
3156 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3159 Targ
:= Defining_Identifier
(Parent
(N
));
3162 -- Replace call with temporary and create its declaration
3164 Temp
:= Make_Temporary
(Loc
, 'C');
3165 Set_Is_Internal
(Temp
);
3167 -- For the unconstrained case, the generated temporary has the
3168 -- same constrained declaration as the result variable. It may
3169 -- eventually be possible to remove that temporary and use the
3170 -- result variable directly.
3172 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3175 Make_Object_Declaration
(Loc
,
3176 Defining_Identifier
=> Temp
,
3177 Object_Definition
=>
3178 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3180 Replace_Formals
(Decl
);
3184 Make_Object_Declaration
(Loc
,
3185 Defining_Identifier
=> Temp
,
3186 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
3188 Set_Etype
(Temp
, Ret_Type
);
3191 Set_No_Initialization
(Decl
);
3192 Append
(Decl
, Decls
);
3193 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3198 Insert_Actions
(N
, Decls
);
3202 -- Special management for inlining a call to a function that returns
3203 -- an unconstrained type and initializes an object declaration: we
3204 -- avoid generating undesired extra calls and goto statements.
3207 -- function Func (...) return ...
3210 -- Result : String (1 .. 4);
3212 -- Proc (Result, ...);
3217 -- Result : String := Func (...);
3219 -- Replace this object declaration by:
3221 -- Result : String (1 .. 4);
3222 -- Proc (Result, ...);
3224 Remove_Homonym
(Targ
);
3227 Make_Object_Declaration
3229 Defining_Identifier
=> Targ
,
3230 Object_Definition
=>
3231 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3232 Replace_Formals
(Decl
);
3233 Rewrite
(Parent
(N
), Decl
);
3234 Analyze
(Parent
(N
));
3236 -- Avoid spurious warnings since we know that this declaration is
3237 -- referenced by the procedure call.
3239 Set_Never_Set_In_Source
(Targ
, False);
3241 -- Remove the local declaration of the extended return stmt from the
3244 Remove
(Parent
(Targ1
));
3246 -- Update the reference to the result (since we have rewriten the
3247 -- object declaration)
3250 Blk_Call_Stmt
: Node_Id
;
3253 -- Capture the call to the procedure
3256 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3258 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
3260 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
3261 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
3262 New_Occurrence_Of
(Targ
, Loc
));
3265 -- Remove the return statement
3268 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3269 N_Simple_Return_Statement
);
3271 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3274 -- Traverse the tree and replace formals with actuals or their thunks.
3275 -- Attach block to tree before analysis and rewriting.
3277 Replace_Formals
(Blk
);
3278 Set_Parent
(Blk
, N
);
3280 if GNATprove_Mode
then
3283 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
3289 -- No action needed since return statement has been already removed
3293 elsif Present
(Exit_Lab
) then
3295 -- If the body was a single expression, the single return statement
3296 -- and the corresponding label are useless.
3300 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
3303 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
3305 Append
(Lab_Decl
, (Declarations
(Blk
)));
3306 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
3310 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3311 -- on conflicting private views that Gigi would ignore. If this is a
3312 -- predefined unit, analyze with checks off, as is done in the non-
3313 -- inlined run-time units.
3316 I_Flag
: constant Boolean := In_Inlined_Body
;
3319 In_Inlined_Body
:= True;
3323 Style
: constant Boolean := Style_Check
;
3326 Style_Check
:= False;
3328 -- Search for dispatching calls that use the Object.Operation
3329 -- notation using an Object that is a parameter of the inlined
3330 -- function. We reset the decoration of Operation to force
3331 -- the reanalysis of the inlined dispatching call because
3332 -- the actual object has been inlined.
3334 Reset_Dispatching_Calls
(Blk
);
3336 Analyze
(Blk
, Suppress
=> All_Checks
);
3337 Style_Check
:= Style
;
3344 In_Inlined_Body
:= I_Flag
;
3347 if Ekind
(Subp
) = E_Procedure
then
3348 Rewrite_Procedure_Call
(N
, Blk
);
3351 Rewrite_Function_Call
(N
, Blk
);
3356 -- For the unconstrained case, the replacement of the call has been
3357 -- made prior to the complete analysis of the generated declarations.
3358 -- Propagate the proper type now.
3361 if Nkind
(N
) = N_Identifier
then
3362 Set_Etype
(N
, Etype
(Entity
(N
)));
3364 Set_Etype
(N
, Etype
(Targ1
));
3371 -- Cleanup mapping between formals and actuals for other expansions
3373 F
:= First_Formal
(Subp
);
3374 while Present
(F
) loop
3375 Set_Renamed_Object
(F
, Empty
);
3378 end Expand_Inlined_Call
;
3380 --------------------------
3381 -- Get_Code_Unit_Entity --
3382 --------------------------
3384 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
3385 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
3388 if Ekind
(Unit
) = E_Package_Body
then
3389 Unit
:= Spec_Entity
(Unit
);
3393 end Get_Code_Unit_Entity
;
3395 ------------------------------
3396 -- Has_Excluded_Declaration --
3397 ------------------------------
3399 function Has_Excluded_Declaration
3401 Decls
: List_Id
) return Boolean
3405 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
3406 -- Nested subprograms make a given body ineligible for inlining, but
3407 -- we make an exception for instantiations of unchecked conversion.
3408 -- The body has not been analyzed yet, so check the name, and verify
3409 -- that the visible entity with that name is the predefined unit.
3411 -----------------------------
3412 -- Is_Unchecked_Conversion --
3413 -----------------------------
3415 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
3416 Id
: constant Node_Id
:= Name
(D
);
3420 if Nkind
(Id
) = N_Identifier
3421 and then Chars
(Id
) = Name_Unchecked_Conversion
3423 Conv
:= Current_Entity
(Id
);
3425 elsif Nkind_In
(Id
, N_Selected_Component
, N_Expanded_Name
)
3426 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
3428 Conv
:= Current_Entity
(Selector_Name
(Id
));
3433 return Present
(Conv
)
3434 and then Is_Predefined_File_Name
3435 (Unit_File_Name
(Get_Source_Unit
(Conv
)))
3436 and then Is_Intrinsic_Subprogram
(Conv
);
3437 end Is_Unchecked_Conversion
;
3439 -- Start of processing for Has_Excluded_Declaration
3442 -- No action needed if the check is not needed
3444 if not Check_Inlining_Restrictions
then
3449 while Present
(D
) loop
3451 -- First declarations universally excluded
3453 if Nkind
(D
) = N_Package_Declaration
then
3455 ("cannot inline & (nested package declaration)?",
3459 elsif Nkind
(D
) = N_Package_Instantiation
then
3461 ("cannot inline & (nested package instantiation)?",
3466 -- Then declarations excluded only for front end inlining
3468 if Back_End_Inlining
then
3471 elsif Nkind
(D
) = N_Task_Type_Declaration
3472 or else Nkind
(D
) = N_Single_Task_Declaration
3475 ("cannot inline & (nested task type declaration)?",
3479 elsif Nkind
(D
) = N_Protected_Type_Declaration
3480 or else Nkind
(D
) = N_Single_Protected_Declaration
3483 ("cannot inline & (nested protected type declaration)?",
3487 elsif Nkind
(D
) = N_Subprogram_Body
then
3489 ("cannot inline & (nested subprogram)?",
3493 elsif Nkind
(D
) = N_Function_Instantiation
3494 and then not Is_Unchecked_Conversion
(D
)
3497 ("cannot inline & (nested function instantiation)?",
3501 elsif Nkind
(D
) = N_Procedure_Instantiation
then
3503 ("cannot inline & (nested procedure instantiation)?",
3512 end Has_Excluded_Declaration
;
3514 ----------------------------
3515 -- Has_Excluded_Statement --
3516 ----------------------------
3518 function Has_Excluded_Statement
3520 Stats
: List_Id
) return Boolean
3526 -- No action needed if the check is not needed
3528 if not Check_Inlining_Restrictions
then
3533 while Present
(S
) loop
3534 if Nkind_In
(S
, N_Abort_Statement
,
3535 N_Asynchronous_Select
,
3536 N_Conditional_Entry_Call
,
3537 N_Delay_Relative_Statement
,
3538 N_Delay_Until_Statement
,
3543 ("cannot inline & (non-allowed statement)?", S
, Subp
);
3546 elsif Nkind
(S
) = N_Block_Statement
then
3547 if Present
(Declarations
(S
))
3548 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
3552 elsif Present
(Handled_Statement_Sequence
(S
)) then
3553 if not Back_End_Inlining
3556 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
3559 ("cannot inline& (exception handler)?",
3560 First
(Exception_Handlers
3561 (Handled_Statement_Sequence
(S
))),
3565 elsif Has_Excluded_Statement
3566 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3572 elsif Nkind
(S
) = N_Case_Statement
then
3573 E
:= First
(Alternatives
(S
));
3574 while Present
(E
) loop
3575 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
3582 elsif Nkind
(S
) = N_If_Statement
then
3583 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
3587 if Present
(Elsif_Parts
(S
)) then
3588 E
:= First
(Elsif_Parts
(S
));
3589 while Present
(E
) loop
3590 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
3598 if Present
(Else_Statements
(S
))
3599 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
3604 elsif Nkind
(S
) = N_Loop_Statement
3605 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
3609 elsif Nkind
(S
) = N_Extended_Return_Statement
then
3610 if Present
(Handled_Statement_Sequence
(S
))
3612 Has_Excluded_Statement
3613 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
3617 elsif not Back_End_Inlining
3618 and then Present
(Handled_Statement_Sequence
(S
))
3620 Present
(Exception_Handlers
3621 (Handled_Statement_Sequence
(S
)))
3624 ("cannot inline& (exception handler)?",
3625 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
3635 end Has_Excluded_Statement
;
3637 --------------------------
3638 -- Has_Initialized_Type --
3639 --------------------------
3641 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
3642 E_Body
: constant Node_Id
:= Get_Subprogram_Body
(E
);
3646 if No
(E_Body
) then -- imported subprogram
3650 Decl
:= First
(Declarations
(E_Body
));
3651 while Present
(Decl
) loop
3652 if Nkind
(Decl
) = N_Full_Type_Declaration
3653 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
3663 end Has_Initialized_Type
;
3665 -----------------------
3666 -- Has_Single_Return --
3667 -----------------------
3669 function Has_Single_Return
(N
: Node_Id
) return Boolean is
3670 Return_Statement
: Node_Id
:= Empty
;
3672 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
3678 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
3680 if Nkind
(N
) = N_Simple_Return_Statement
then
3681 if Present
(Expression
(N
))
3682 and then Is_Entity_Name
(Expression
(N
))
3684 if No
(Return_Statement
) then
3685 Return_Statement
:= N
;
3688 elsif Chars
(Expression
(N
)) =
3689 Chars
(Expression
(Return_Statement
))
3697 -- A return statement within an extended return is a noop
3700 elsif No
(Expression
(N
))
3702 Nkind
(Parent
(Parent
(N
))) = N_Extended_Return_Statement
3707 -- Expression has wrong form
3712 -- We can only inline a build-in-place function if it has a single
3715 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3716 if No
(Return_Statement
) then
3717 Return_Statement
:= N
;
3729 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
3731 -- Start of processing for Has_Single_Return
3734 if Check_All_Returns
(N
) /= OK
then
3737 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
3741 return Present
(Declarations
(N
))
3742 and then Present
(First
(Declarations
(N
)))
3743 and then Chars
(Expression
(Return_Statement
)) =
3744 Chars
(Defining_Identifier
(First
(Declarations
(N
))));
3746 end Has_Single_Return
;
3748 -----------------------------
3749 -- In_Main_Unit_Or_Subunit --
3750 -----------------------------
3752 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
3753 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
3756 -- Check whether the subprogram or package to inline is within the main
3757 -- unit or its spec or within a subunit. In either case there are no
3758 -- additional bodies to process. If the subprogram appears in a parent
3759 -- of the current unit, the check on whether inlining is possible is
3760 -- done in Analyze_Inlined_Bodies.
3762 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
3763 Comp
:= Library_Unit
(Comp
);
3766 return Comp
= Cunit
(Main_Unit
)
3767 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
3768 end In_Main_Unit_Or_Subunit
;
3774 procedure Initialize
is
3776 Pending_Descriptor
.Init
;
3777 Pending_Instantiations
.Init
;
3778 Inlined_Bodies
.Init
;
3782 for J
in Hash_Headers
'Range loop
3783 Hash_Headers
(J
) := No_Subp
;
3786 Inlined_Calls
:= No_Elist
;
3787 Backend_Calls
:= No_Elist
;
3788 Backend_Inlined_Subps
:= No_Elist
;
3789 Backend_Not_Inlined_Subps
:= No_Elist
;
3792 ------------------------
3793 -- Instantiate_Bodies --
3794 ------------------------
3796 -- Generic bodies contain all the non-local references, so an
3797 -- instantiation does not need any more context than Standard
3798 -- itself, even if the instantiation appears in an inner scope.
3799 -- Generic associations have verified that the contract model is
3800 -- satisfied, so that any error that may occur in the analysis of
3801 -- the body is an internal error.
3803 procedure Instantiate_Bodies
is
3805 Info
: Pending_Body_Info
;
3808 if Serious_Errors_Detected
= 0 then
3809 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
3810 Push_Scope
(Standard_Standard
);
3811 To_Clean
:= New_Elmt_List
;
3813 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3817 -- A body instantiation may generate additional instantiations, so
3818 -- the following loop must scan to the end of a possibly expanding
3819 -- set (that's why we can't simply use a FOR loop here).
3822 while J
<= Pending_Instantiations
.Last
3823 and then Serious_Errors_Detected
= 0
3825 Info
:= Pending_Instantiations
.Table
(J
);
3827 -- If the instantiation node is absent, it has been removed
3828 -- as part of unreachable code.
3830 if No
(Info
.Inst_Node
) then
3833 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
3834 Instantiate_Package_Body
(Info
);
3835 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
3838 Instantiate_Subprogram_Body
(Info
);
3844 -- Reset the table of instantiations. Additional instantiations
3845 -- may be added through inlining, when additional bodies are
3848 Pending_Instantiations
.Init
;
3850 -- We can now complete the cleanup actions of scopes that contain
3851 -- pending instantiations (skipped for generic units, since we
3852 -- never need any cleanups in generic units).
3853 -- pending instantiations.
3856 and then not Is_Generic_Unit
(Main_Unit_Entity
)
3859 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
3865 end Instantiate_Bodies
;
3871 function Is_Nested
(E
: Entity_Id
) return Boolean is
3876 while Scop
/= Standard_Standard
loop
3877 if Ekind
(Scop
) in Subprogram_Kind
then
3880 elsif Ekind
(Scop
) = E_Task_Type
3881 or else Ekind
(Scop
) = E_Entry
3882 or else Ekind
(Scop
) = E_Entry_Family
3887 Scop
:= Scope
(Scop
);
3893 ------------------------
3894 -- List_Inlining_Info --
3895 ------------------------
3897 procedure List_Inlining_Info
is
3903 if not Debug_Flag_Dot_J
then
3907 -- Generate listing of calls inlined by the frontend
3909 if Present
(Inlined_Calls
) then
3911 Elmt
:= First_Elmt
(Inlined_Calls
);
3912 while Present
(Elmt
) loop
3915 if In_Extended_Main_Code_Unit
(Nod
) then
3919 Write_Str
("List of calls inlined by the frontend");
3926 Write_Location
(Sloc
(Nod
));
3935 -- Generate listing of calls passed to the backend
3937 if Present
(Backend_Calls
) then
3940 Elmt
:= First_Elmt
(Backend_Calls
);
3941 while Present
(Elmt
) loop
3944 if In_Extended_Main_Code_Unit
(Nod
) then
3948 Write_Str
("List of inlined calls passed to the backend");
3955 Write_Location
(Sloc
(Nod
));
3963 -- Generate listing of subprograms passed to the backend
3965 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
3968 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
3969 while Present
(Elmt
) loop
3976 ("List of inlined subprograms passed to the backend");
3983 Write_Name
(Chars
(Nod
));
3985 Write_Location
(Sloc
(Nod
));
3993 -- Generate listing of subprograms that cannot be inlined by the backend
3995 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
3998 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
3999 while Present
(Elmt
) loop
4006 ("List of subprograms that cannot be inlined by the backend");
4013 Write_Name
(Chars
(Nod
));
4015 Write_Location
(Sloc
(Nod
));
4022 end List_Inlining_Info
;
4030 Pending_Instantiations
.Locked
:= True;
4031 Inlined_Bodies
.Locked
:= True;
4032 Successors
.Locked
:= True;
4033 Inlined
.Locked
:= True;
4034 Pending_Instantiations
.Release
;
4035 Inlined_Bodies
.Release
;
4040 --------------------------------
4041 -- Remove_Aspects_And_Pragmas --
4042 --------------------------------
4044 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
4045 procedure Remove_Items
(List
: List_Id
);
4046 -- Remove all useless aspects/pragmas from a particular list
4052 procedure Remove_Items
(List
: List_Id
) is
4055 Next_Item
: Node_Id
;
4058 -- Traverse the list looking for an aspect specification or a pragma
4060 Item
:= First
(List
);
4061 while Present
(Item
) loop
4062 Next_Item
:= Next
(Item
);
4064 if Nkind
(Item
) = N_Aspect_Specification
then
4065 Item_Id
:= Identifier
(Item
);
4066 elsif Nkind
(Item
) = N_Pragma
then
4067 Item_Id
:= Pragma_Identifier
(Item
);
4072 if Present
(Item_Id
)
4073 and then Nam_In
(Chars
(Item_Id
), Name_Contract_Cases
,
4078 Name_Refined_Global
,
4079 Name_Refined_Depends
,
4092 -- Start of processing for Remove_Aspects_And_Pragmas
4095 Remove_Items
(Aspect_Specifications
(Body_Decl
));
4096 Remove_Items
(Declarations
(Body_Decl
));
4097 end Remove_Aspects_And_Pragmas
;
4099 --------------------------
4100 -- Remove_Dead_Instance --
4101 --------------------------
4103 procedure Remove_Dead_Instance
(N
: Node_Id
) is
4108 while J
<= Pending_Instantiations
.Last
loop
4109 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
4110 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
4116 end Remove_Dead_Instance
;