1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2024, 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 ------------------------------------------------------------------------------
27 with Aspects
; use Aspects
;
28 with Atree
; use Atree
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Exp_Ch6
; use Exp_Ch6
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Exp_Util
; use Exp_Util
;
39 with Fname
; use Fname
;
40 with Fname
.UF
; use Fname
.UF
;
42 with Namet
; use Namet
;
43 with Nmake
; use Nmake
;
44 with Nlists
; use Nlists
;
45 with Output
; use Output
;
46 with Sem_Aux
; use Sem_Aux
;
47 with Sem_Ch8
; use Sem_Ch8
;
48 with Sem_Ch10
; use Sem_Ch10
;
49 with Sem_Ch12
; use Sem_Ch12
;
50 with Sem_Prag
; use Sem_Prag
;
51 with Sem_Res
; use Sem_Res
;
52 with Sem_Util
; use Sem_Util
;
53 with Sinfo
; use Sinfo
;
54 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
55 with Sinfo
.Utils
; use Sinfo
.Utils
;
56 with Sinput
; use Sinput
;
57 with Snames
; use Snames
;
58 with Stand
; use Stand
;
60 with Tbuild
; use Tbuild
;
61 with Uintp
; use Uintp
;
62 with Uname
; use Uname
;
66 package body Inline
is
68 Check_Inlining_Restrictions
: constant Boolean := True;
69 -- In the following cases the frontend rejects inlining because they
70 -- are not handled well by the backend. This variable facilitates
71 -- disabling these restrictions to evaluate future versions of the
72 -- GCC backend in which some of the restrictions may be supported.
74 -- - subprograms that have:
75 -- - nested subprograms
77 -- - package declarations
78 -- - task or protected object declarations
79 -- - some of the following statements:
81 -- - asynchronous-select
82 -- - conditional-entry-call
88 Inlined_Calls
: Elist_Id
;
89 -- List of frontend inlined calls
91 Backend_Calls
: Elist_Id
;
92 -- List of inline calls passed to the backend
94 Backend_Instances
: Elist_Id
;
95 -- List of instances inlined for the backend
97 Backend_Inlined_Subps
: Elist_Id
;
98 -- List of subprograms inlined by the backend
100 Backend_Not_Inlined_Subps
: Elist_Id
;
101 -- List of subprograms that cannot be inlined by the backend
103 -----------------------------
104 -- Pending_Instantiations --
105 -----------------------------
107 -- We make entries in this table for the pending instantiations of generic
108 -- bodies that are created during semantic analysis. After the analysis is
109 -- complete, calling Instantiate_Bodies performs the actual instantiations.
111 package Pending_Instantiations
is new Table
.Table
(
112 Table_Component_Type
=> Pending_Body_Info
,
113 Table_Index_Type
=> Int
,
114 Table_Low_Bound
=> 0,
115 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
116 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
117 Table_Name
=> "Pending_Instantiations");
119 -------------------------------------
120 -- Called_Pending_Instantiations --
121 -------------------------------------
123 -- With back-end inlining, the pending instantiations that are not in the
124 -- main unit or subunit are performed only after a call to the subprogram
125 -- instance, or to a subprogram within the package instance, is inlined.
126 -- Since such a call can be within a subsequent pending instantiation,
127 -- we make entries in this table that stores the index of these "called"
128 -- pending instantiations and perform them when the table is populated.
130 package Called_Pending_Instantiations
is new Table
.Table
(
131 Table_Component_Type
=> Int
,
132 Table_Index_Type
=> Int
,
133 Table_Low_Bound
=> 0,
134 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
135 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
136 Table_Name
=> "Called_Pending_Instantiations");
138 ---------------------------------
139 -- To_Pending_Instantiations --
140 ---------------------------------
142 -- With back-end inlining, we also need to have a map from the pending
143 -- instantiations to their index in the Pending_Instantiations table.
145 Node_Table_Size
: constant := 257;
146 -- Number of headers in hash table
148 subtype Node_Header_Num
is Integer range 0 .. Node_Table_Size
- 1;
149 -- Range of headers in hash table
151 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
;
152 -- Simple hash function for Node_Ids
154 package To_Pending_Instantiations
is new GNAT
.Htable
.Simple_HTable
155 (Header_Num
=> Node_Header_Num
,
166 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
is
168 return Node_Header_Num
(Id
mod Node_Table_Size
);
175 -- Inlined functions are actually placed in line by the backend if the
176 -- corresponding bodies are available (i.e. compiled). Whenever we find
177 -- a call to an inlined subprogram, we add the name of the enclosing
178 -- compilation unit to a worklist. After all compilation, and after
179 -- expansion of generic bodies, we traverse the list of pending bodies
180 -- and compile them as well.
182 package Inlined_Bodies
is new Table
.Table
(
183 Table_Component_Type
=> Entity_Id
,
184 Table_Index_Type
=> Int
,
185 Table_Low_Bound
=> 0,
186 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
187 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
188 Table_Name
=> "Inlined_Bodies");
190 -----------------------
191 -- Inline Processing --
192 -----------------------
194 -- For each call to an inlined subprogram, we make entries in a table
195 -- that stores caller and callee, and indicates the call direction from
196 -- one to the other. We also record the compilation unit that contains
197 -- the callee. After analyzing the bodies of all such compilation units,
198 -- we compute the transitive closure of inlined subprograms called from
199 -- the main compilation unit and make it available to the code generator
200 -- in no particular order, thus allowing cycles in the call graph.
202 Last_Inlined
: Entity_Id
:= Empty
;
204 -- For each entry in the table we keep a list of successors in topological
205 -- order, i.e. callers of the current subprogram.
207 type Subp_Index
is new Nat
;
208 No_Subp
: constant Subp_Index
:= 0;
210 -- The subprogram entities are hashed into the Inlined table
212 Num_Hash_Headers
: constant := 512;
214 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
217 type Succ_Index
is new Nat
;
218 No_Succ
: constant Succ_Index
:= 0;
220 type Succ_Info
is record
225 -- The following table stores list elements for the successor lists. These
226 -- lists cannot be chained directly through entries in the Inlined table,
227 -- because a given subprogram can appear in several such lists.
229 package Successors
is new Table
.Table
(
230 Table_Component_Type
=> Succ_Info
,
231 Table_Index_Type
=> Succ_Index
,
232 Table_Low_Bound
=> 1,
233 Table_Initial
=> Alloc
.Successors_Initial
,
234 Table_Increment
=> Alloc
.Successors_Increment
,
235 Table_Name
=> "Successors");
237 type Subp_Info
is record
238 Name
: Entity_Id
:= Empty
;
239 Next
: Subp_Index
:= No_Subp
;
240 First_Succ
: Succ_Index
:= No_Succ
;
241 Main_Call
: Boolean := False;
242 Processed
: Boolean := False;
245 package Inlined
is new Table
.Table
(
246 Table_Component_Type
=> Subp_Info
,
247 Table_Index_Type
=> Subp_Index
,
248 Table_Low_Bound
=> 1,
249 Table_Initial
=> Alloc
.Inlined_Initial
,
250 Table_Increment
=> Alloc
.Inlined_Increment
,
251 Table_Name
=> "Inlined");
253 -----------------------
254 -- Local Subprograms --
255 -----------------------
257 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
258 -- Make two entries in Inlined table, for an inlined subprogram being
259 -- called, and for the inlined subprogram that contains the call. If
260 -- the call is in the main compilation unit, Caller is Empty.
262 procedure Add_Inlined_Instance
(E
: Entity_Id
);
263 -- Add instance E to the list of inlined instances for the unit
265 procedure Add_Inlined_Subprogram
(E
: Entity_Id
);
266 -- Add subprogram E to the list of inlined subprograms for the unit
268 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
269 -- Make entry in Inlined table for subprogram E, or return table index
270 -- that already holds E.
272 procedure Establish_Actual_Mapping_For_Inlined_Call
276 Body_Or_Expr_To_Check
: Node_Id
);
277 -- Establish a mapping from formals to actuals in the call N for the target
278 -- subprogram Subp, and create temporaries or renamings when needed for the
279 -- actuals that are expressions (except for actuals given by simple entity
280 -- names or literals) or that are scalars that require copying to preserve
281 -- semantics. Any temporary objects that are created are inserted in Decls.
282 -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
283 -- of an expression function), which may be traversed to count formal uses.
285 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
;
286 pragma Inline
(Get_Code_Unit_Entity
);
287 -- Return the entity node for the unit containing E. Always return the spec
290 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
291 -- If a candidate for inlining contains type declarations for types with
292 -- nontrivial initialization procedures, they are not worth inlining.
294 function Has_Single_Return
(N
: Node_Id
) return Boolean;
295 -- In general we cannot inline functions that return unconstrained type.
296 -- However, we can handle such functions if all return statements return
297 -- a local variable that is the first declaration in the body of the
298 -- function. In that case the call can be replaced by that local
299 -- variable as is done for other inlined calls.
301 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean;
302 -- Return True if E is in the main unit or its spec or in a subunit
304 function Is_Nested
(E
: Entity_Id
) return Boolean;
305 -- If the function is nested inside some other function, it will always
306 -- be compiled if that function is, so don't add it to the inline list.
307 -- We cannot compile a nested function outside the scope of the containing
308 -- function anyway. This is also the case if the function is defined in a
309 -- task body or within an entry (for example, an initialization procedure).
311 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
);
312 -- Remove all aspects and/or pragmas that have no meaning in inlined body
313 -- Body_Decl. The analysis of these items is performed on the non-inlined
314 -- body. The items currently removed are:
325 -- Subprogram_Variant
330 procedure Reset_Actual_Mapping_For_Inlined_Call
(Subp
: Entity_Id
);
331 -- Reset the Renamed_Object field to Empty on all formals of Subp, which
332 -- can be set by a call to Establish_Actual_Mapping_For_Inlined_Call.
334 ------------------------------
335 -- Deferred Cleanup Actions --
336 ------------------------------
338 -- The cleanup actions for scopes that contain package instantiations with
339 -- a body are delayed until after the package body is instantiated. because
340 -- the body may contain finalizable objects or other constructs that affect
341 -- the cleanup code. A scope that contains such instantiations only needs
342 -- to be finalized once, even though it may contain more than one instance.
343 -- We keep a list of scopes that must still be finalized and Cleanup_Scopes
344 -- will be invoked after all the body instantiations have been completed.
348 procedure Add_Scope_To_Clean
(Scop
: Entity_Id
);
349 -- Build set of scopes on which cleanup actions must be performed
351 procedure Cleanup_Scopes
;
352 -- Complete cleanup actions on scopes that need it
358 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
359 P1
: constant Subp_Index
:= Add_Subp
(Called
);
364 if Present
(Caller
) then
365 P2
:= Add_Subp
(Caller
);
367 -- Add P1 to the list of successors of P2, if not already there.
368 -- Note that P2 may contain more than one call to P1, and only
369 -- one needs to be recorded.
371 J
:= Inlined
.Table
(P2
).First_Succ
;
372 while J
/= No_Succ
loop
373 if Successors
.Table
(J
).Subp
= P1
then
377 J
:= Successors
.Table
(J
).Next
;
380 -- On exit, make a successor entry for P1
382 Successors
.Increment_Last
;
383 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
384 Successors
.Table
(Successors
.Last
).Next
:=
385 Inlined
.Table
(P2
).First_Succ
;
386 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
388 Inlined
.Table
(P1
).Main_Call
:= True;
392 ----------------------
393 -- Add_Inlined_Body --
394 ----------------------
396 procedure Add_Inlined_Body
(E
: Entity_Id
; N
: Node_Id
) is
398 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
399 -- Level of inlining for the call: Dont_Inline means no inlining,
400 -- Inline_Call means that only the call is considered for inlining,
401 -- Inline_Package means that the call is considered for inlining and
402 -- its package compiled and scanned for more inlining opportunities.
404 function Is_Non_Loading_Expression_Function
405 (Id
: Entity_Id
) return Boolean;
406 -- Determine whether arbitrary entity Id denotes a subprogram which is
409 -- * An expression function
411 -- * A function completed by an expression function where both the
412 -- spec and body are in the same context.
414 function Must_Inline
return Inline_Level_Type
;
415 -- Inlining is only done if the call statement N is in the main unit,
416 -- or within the body of another inlined subprogram.
418 ----------------------------------------
419 -- Is_Non_Loading_Expression_Function --
420 ----------------------------------------
422 function Is_Non_Loading_Expression_Function
423 (Id
: Entity_Id
) return Boolean
430 -- A stand-alone expression function is transformed into a spec-body
431 -- pair in-place. Since both the spec and body are in the same list,
432 -- the inlining of such an expression function does not need to load
435 if Is_Expression_Function
(Id
) then
438 -- A function may be completed by an expression function
440 elsif Ekind
(Id
) = E_Function
then
441 Spec_Decl
:= Unit_Declaration_Node
(Id
);
443 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
then
444 Body_Id
:= Corresponding_Body
(Spec_Decl
);
446 if Present
(Body_Id
) then
447 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
449 -- The inlining of a completing expression function does
450 -- not need to load anything extra when both the spec and
451 -- body are in the same context.
454 Was_Expression_Function
(Body_Decl
)
455 and then Parent
(Spec_Decl
) = Parent
(Body_Decl
);
461 end Is_Non_Loading_Expression_Function
;
467 function Must_Inline
return Inline_Level_Type
is
472 -- Check if call is in main unit
474 Scop
:= Current_Scope
;
476 -- Do not try to inline if scope is standard. This could happen, for
477 -- example, for a call to Add_Global_Declaration, and it causes
478 -- trouble to try to inline at this level.
480 if Scop
= Standard_Standard
then
484 -- Otherwise lookup scope stack to outer scope
486 while Scope
(Scop
) /= Standard_Standard
487 and then not Is_Child_Unit
(Scop
)
489 Scop
:= Scope
(Scop
);
492 Comp
:= Parent
(Scop
);
493 while Nkind
(Comp
) /= N_Compilation_Unit
loop
494 Comp
:= Parent
(Comp
);
497 -- If the call is in the main unit, inline the call and compile the
498 -- package of the subprogram to find more calls to be inlined.
500 if Comp
= Cunit
(Main_Unit
)
501 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
504 return Inline_Package
;
507 -- The call is not in the main unit. See if it is in some subprogram
508 -- that can be inlined outside its unit. If so, inline the call and,
509 -- if the inlining level is set to 1, stop there; otherwise also
510 -- compile the package as above.
512 Scop
:= Current_Scope
;
513 while Scope
(Scop
) /= Standard_Standard
514 and then not Is_Child_Unit
(Scop
)
516 if Is_Overloadable
(Scop
)
517 and then Is_Inlined
(Scop
)
518 and then not Is_Nested
(Scop
)
522 if Inline_Level
= 1 then
525 return Inline_Package
;
529 Scop
:= Scope
(Scop
);
537 Level
: Inline_Level_Type
;
539 -- Start of processing for Add_Inlined_Body
542 Append_New_Elmt
(N
, To
=> Backend_Calls
);
544 -- Skip subprograms that cannot or need not be inlined outside their
545 -- unit or parent subprogram.
547 if Is_Abstract_Subprogram
(E
)
548 or else Convention
(E
) = Convention_Protected
549 or else In_Main_Unit_Or_Subunit
(E
)
550 or else Is_Nested
(E
)
555 -- Find out whether the call must be inlined. Unless the result is
556 -- Dont_Inline, Must_Inline also creates an edge for the call in the
557 -- callgraph; however, it will not be activated until after Is_Called
558 -- is set on the subprogram.
560 Level
:= Must_Inline
;
562 if Level
= Dont_Inline
then
566 -- If a previous call to the subprogram has been inlined, nothing to do
568 if Is_Called
(E
) then
572 -- If the subprogram is an instance, then inline the instance
574 if Is_Generic_Instance
(E
) then
575 Add_Inlined_Instance
(E
);
578 -- Mark the subprogram as called
582 -- If the call was generated by the compiler and is to a subprogram in
583 -- a run-time unit, we need to suppress debugging information for it,
584 -- so that the code that is eventually inlined will not affect the
585 -- debugging of the program. We do not do it if the call comes from
586 -- source because, even if the call is inlined, the user may expect it
587 -- to be present in the debugging information.
589 if not Comes_From_Source
(N
)
590 and then In_Extended_Main_Source_Unit
(N
)
591 and then Is_Predefined_Unit
(Get_Source_Unit
(E
))
593 Set_Needs_Debug_Info
(E
, False);
596 -- If the subprogram is an expression function, or is completed by one
597 -- where both the spec and body are in the same context, then there is
598 -- no need to load any package body since the body of the function is
601 if Is_Non_Loading_Expression_Function
(E
) then
605 -- Find unit containing E, and add to list of inlined bodies if needed.
606 -- Library-level functions must be handled specially, because there is
607 -- no enclosing package to retrieve. In this case, it is the body of
608 -- the function that will have to be loaded.
611 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
615 Inlined_Bodies
.Increment_Last
;
616 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
619 pragma Assert
(Ekind
(Pack
) = E_Package
);
621 -- If the subprogram is within an instance, inline the instance
623 if Comes_From_Source
(E
) then
626 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
627 exit when Is_Generic_Instance
(Inst
);
628 Inst
:= Scope
(Inst
);
632 and then Is_Generic_Instance
(Inst
)
633 and then not Is_Called
(Inst
)
635 Inst_Decl
:= Unit_Declaration_Node
(Inst
);
637 -- Do not inline the instance if the body already exists,
638 -- or the instance node is simply missing.
640 if Present
(Corresponding_Body
(Inst_Decl
))
641 or else (Nkind
(Parent
(Inst_Decl
)) /= N_Compilation_Unit
642 and then No
(Next
(Inst_Decl
)))
644 Set_Is_Called
(Inst
);
646 Add_Inlined_Instance
(Inst
);
651 -- If the unit containing E is an instance, nothing more to do
653 if Is_Generic_Instance
(Pack
) then
656 -- Do not inline the package if the subprogram is an init proc
657 -- or other internally generated subprogram, because in that
658 -- case the subprogram body appears in the same unit that
659 -- declares the type, and that body is visible to the back end.
660 -- Do not inline it either if it is in the main unit.
661 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
662 -- calls if the back end takes care of inlining the call.
663 -- Note that Level is in Inline_Call | Inline_Package here.
665 elsif ((Level
= Inline_Call
666 and then Has_Pragma_Inline_Always
(E
)
667 and then Back_End_Inlining
)
668 or else Level
= Inline_Package
)
669 and then not Is_Inlined
(Pack
)
670 and then not Is_Internal
(E
)
671 and then not In_Main_Unit_Or_Subunit
(Pack
)
673 Set_Is_Inlined
(Pack
);
674 Inlined_Bodies
.Increment_Last
;
675 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
679 -- Ensure that Analyze_Inlined_Bodies will be invoked after
680 -- completing the analysis of the current unit.
682 Inline_Processing_Required
:= True;
684 end Add_Inlined_Body
;
686 --------------------------
687 -- Add_Inlined_Instance --
688 --------------------------
690 procedure Add_Inlined_Instance
(E
: Entity_Id
) is
691 Decl_Node
: constant Node_Id
:= Unit_Declaration_Node
(E
);
695 -- This machinery is only used with back-end inlining
697 if not Back_End_Inlining
then
701 -- Register the instance in the list
703 Append_New_Elmt
(Decl_Node
, To
=> Backend_Instances
);
705 -- Retrieve the index of its corresponding pending instantiation
706 -- and mark this corresponding pending instantiation as needed.
708 Index
:= To_Pending_Instantiations
.Get
(Decl_Node
);
710 Called_Pending_Instantiations
.Append
(Index
);
712 pragma Assert
(False);
717 end Add_Inlined_Instance
;
719 ----------------------------
720 -- Add_Inlined_Subprogram --
721 ----------------------------
723 procedure Add_Inlined_Subprogram
(E
: Entity_Id
) is
724 Decl
: constant Node_Id
:= Parent
(Declaration_Node
(E
));
725 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
727 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
728 -- Append Subp to the list of subprograms inlined by the backend
730 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
731 -- Append Subp to the list of subprograms that cannot be inlined by
734 -----------------------------------------
735 -- Register_Backend_Inlined_Subprogram --
736 -----------------------------------------
738 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
740 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
741 end Register_Backend_Inlined_Subprogram
;
743 ---------------------------------------------
744 -- Register_Backend_Not_Inlined_Subprogram --
745 ---------------------------------------------
747 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
749 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
750 end Register_Backend_Not_Inlined_Subprogram
;
752 -- Start of processing for Add_Inlined_Subprogram
755 -- We can inline the subprogram if its unit is known to be inlined or is
756 -- an instance whose body will be analyzed anyway or the subprogram was
757 -- generated as a body by the compiler (for example an initialization
758 -- procedure) or its declaration was provided along with the body (for
759 -- example an expression function) and it does not declare types with
760 -- nontrivial initialization procedures.
762 if (Is_Inlined
(Pack
)
763 or else Is_Generic_Instance
(Pack
)
764 or else Nkind
(Decl
) = N_Subprogram_Body
765 or else Present
(Corresponding_Body
(Decl
)))
766 and then not Has_Initialized_Type
(E
)
768 Register_Backend_Inlined_Subprogram
(E
);
770 if No
(Last_Inlined
) then
771 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
773 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
779 Register_Backend_Not_Inlined_Subprogram
(E
);
781 end Add_Inlined_Subprogram
;
783 --------------------------------
784 -- Add_Pending_Instantiation --
785 --------------------------------
787 procedure Add_Pending_Instantiation
790 Fin_Scop
: Node_Id
:= Empty
)
792 Act_Decl_Id
: Entity_Id
;
796 -- Here is a defense against a ludicrous number of instantiations
797 -- caused by a circular set of instantiation attempts.
799 if Pending_Instantiations
.Last
+ 1 >= Maximum_Instantiations
then
800 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
801 Error_Msg_N
("too many instantiations, exceeds max of^", Inst
);
802 Error_Msg_N
("\limit can be changed using -gnateinn switch", Inst
);
803 raise Unrecoverable_Error
;
806 -- Capture the body of the generic instantiation along with its context
807 -- for later processing by Instantiate_Bodies.
809 Pending_Instantiations
.Append
811 Act_Decl
=> Act_Decl
,
812 Fin_Scop
=> Fin_Scop
,
813 Config_Switches
=> Save_Config_Switches
,
814 Current_Sem_Unit
=> Current_Sem_Unit
,
815 Expander_Status
=> Expander_Active
,
816 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
817 Scope_Suppress
=> Scope_Suppress
,
818 Warnings
=> Save_Warnings
));
820 -- With back-end inlining, also associate the index to the instantiation
822 if Back_End_Inlining
then
823 Act_Decl_Id
:= Defining_Entity
(Act_Decl
);
824 Index
:= Pending_Instantiations
.Last
;
826 To_Pending_Instantiations
.Set
(Act_Decl
, Index
);
828 -- If an instantiation is in the main unit or subunit, or is a nested
829 -- subprogram, then its body is needed as per the analysis done in
830 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
832 if In_Main_Unit_Or_Subunit
(Act_Decl_Id
)
833 or else (Is_Subprogram
(Act_Decl_Id
)
834 and then Is_Nested
(Act_Decl_Id
))
836 Called_Pending_Instantiations
.Append
(Index
);
838 Set_Is_Called
(Act_Decl_Id
);
841 end Add_Pending_Instantiation
;
843 ------------------------
844 -- Add_Scope_To_Clean --
845 ------------------------
847 procedure Add_Scope_To_Clean
(Scop
: Entity_Id
) is
851 Elmt
:= First_Elmt
(To_Clean
);
852 while Present
(Elmt
) loop
853 if Node
(Elmt
) = Scop
then
860 Append_Elmt
(Scop
, To_Clean
);
861 end Add_Scope_To_Clean
;
867 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
868 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
872 -- Initialize entry in Inlined table
874 procedure New_Entry
is
876 Inlined
.Increment_Last
;
877 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
878 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
879 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
880 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
881 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
884 -- Start of processing for Add_Subp
887 if Hash_Headers
(Index
) = No_Subp
then
889 Hash_Headers
(Index
) := Inlined
.Last
;
893 J
:= Hash_Headers
(Index
);
894 while J
/= No_Subp
loop
895 if Inlined
.Table
(J
).Name
= E
then
899 J
:= Inlined
.Table
(J
).Next
;
903 -- On exit, subprogram was not found. Enter in table. Index is
904 -- the current last entry on the hash chain.
907 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
912 ----------------------------
913 -- Analyze_Inlined_Bodies --
914 ----------------------------
916 procedure Analyze_Inlined_Bodies
is
923 type Pending_Index
is new Nat
;
925 package Pending_Inlined
is new Table
.Table
(
926 Table_Component_Type
=> Subp_Index
,
927 Table_Index_Type
=> Pending_Index
,
928 Table_Low_Bound
=> 1,
929 Table_Initial
=> Alloc
.Inlined_Initial
,
930 Table_Increment
=> Alloc
.Inlined_Increment
,
931 Table_Name
=> "Pending_Inlined");
932 -- The workpile used to compute the transitive closure
934 -- Start of processing for Analyze_Inlined_Bodies
937 if Serious_Errors_Detected
= 0 then
938 Push_Scope
(Standard_Standard
);
941 while J
<= Inlined_Bodies
.Last
942 and then Serious_Errors_Detected
= 0
944 Pack
:= Inlined_Bodies
.Table
(J
);
946 and then Scope
(Pack
) /= Standard_Standard
947 and then not Is_Child_Unit
(Pack
)
949 Pack
:= Scope
(Pack
);
952 Comp_Unit
:= Parent
(Pack
);
953 while Present
(Comp_Unit
)
954 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
956 Comp_Unit
:= Parent
(Comp_Unit
);
959 -- Load the body if it exists and contains inlineable entities,
960 -- unless it is the main unit, or is an instance whose body has
961 -- already been analyzed.
963 if Present
(Comp_Unit
)
964 and then Comp_Unit
/= Cunit
(Main_Unit
)
965 and then Body_Required
(Comp_Unit
)
967 (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
969 (No
(Corresponding_Body
(Unit
(Comp_Unit
)))
970 and then Body_Needed_For_Inlining
971 (Defining_Entity
(Unit
(Comp_Unit
)))))
974 Bname
: constant Unit_Name_Type
:=
975 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
980 if not Is_Loaded
(Bname
) then
981 Style_Check
:= False;
982 Load_Needed_Body
(Comp_Unit
, OK
);
986 -- Warn that a body was not available for inlining
989 Error_Msg_Unit_1
:= Bname
;
991 ("one or more inlined subprograms accessed in $!??",
994 Get_File_Name
(Bname
, Subunit
=> False);
995 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
1003 if J
> Inlined_Bodies
.Last
then
1005 -- The analysis of required bodies may have produced additional
1006 -- generic instantiations. To obtain further inlining, we need
1007 -- to perform another round of generic body instantiations.
1011 -- Symmetrically, the instantiation of required generic bodies
1012 -- may have caused additional bodies to be inlined. To obtain
1013 -- further inlining, we keep looping over the inlined bodies.
1017 -- The list of inlined subprograms is an overestimate, because it
1018 -- includes inlined functions called from functions that are compiled
1019 -- as part of an inlined package, but are not themselves called. An
1020 -- accurate computation of just those subprograms that are needed
1021 -- requires that we perform a transitive closure over the call graph,
1022 -- starting from calls in the main compilation unit.
1024 for Index
in Inlined
.First
.. Inlined
.Last
loop
1025 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
1027 -- This means that Add_Inlined_Body added the subprogram to the
1028 -- table but wasn't able to handle its code unit. Do nothing.
1030 Inlined
.Table
(Index
).Processed
:= True;
1032 elsif Inlined
.Table
(Index
).Main_Call
then
1033 Pending_Inlined
.Increment_Last
;
1034 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
1035 Inlined
.Table
(Index
).Processed
:= True;
1038 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
1042 -- Iterate over the workpile until it is emptied, propagating the
1043 -- Is_Called flag to the successors of the processed subprogram.
1045 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
1046 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
1047 Pending_Inlined
.Decrement_Last
;
1049 S
:= Inlined
.Table
(Subp
).First_Succ
;
1051 while S
/= No_Succ
loop
1052 Subp
:= Successors
.Table
(S
).Subp
;
1054 if not Inlined
.Table
(Subp
).Processed
then
1055 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
1056 Pending_Inlined
.Increment_Last
;
1057 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
1058 Inlined
.Table
(Subp
).Processed
:= True;
1061 S
:= Successors
.Table
(S
).Next
;
1065 -- Finally add the called subprograms to the list of inlined
1066 -- subprograms for the unit.
1068 for Index
in Inlined
.First
.. Inlined
.Last
loop
1070 E
: constant Subprogram_Kind_Id
:= Inlined
.Table
(Index
).Name
;
1073 if Is_Called
(E
) and then not Is_Ignored_Ghost_Entity
(E
) then
1074 Add_Inlined_Subprogram
(E
);
1081 end Analyze_Inlined_Bodies
;
1083 --------------------------
1084 -- Build_Body_To_Inline --
1085 --------------------------
1087 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1088 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1089 Original_Body
: Node_Id
;
1090 Body_To_Analyze
: Node_Id
;
1091 Max_Size
: constant := 10;
1093 function Has_Extended_Return
return Boolean;
1094 -- This function returns True if the subprogram has an extended return
1097 function Has_Pending_Instantiation
return Boolean;
1098 -- If some enclosing body contains instantiations that appear before
1099 -- the corresponding generic body, the enclosing body has a freeze node
1100 -- so that it can be elaborated after the generic itself. This might
1101 -- conflict with subsequent inlinings, so that it is unsafe to try to
1102 -- inline in such a case.
1104 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
1105 -- This function is called only in GNATprove mode, and it returns
1106 -- True if the subprogram has no return statement or a single return
1107 -- statement as last statement. It returns False for subprogram with
1108 -- a single return as last statement inside one or more blocks, as
1109 -- inlining would generate gotos in that case as well (although the
1110 -- goto is useless in that case).
1112 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
1113 -- If the body of the subprogram includes a call that returns an
1114 -- unconstrained type, the secondary stack is involved, and it is
1115 -- not worth inlining.
1117 -------------------------
1118 -- Has_Extended_Return --
1119 -------------------------
1121 function Has_Extended_Return
return Boolean is
1122 Body_To_Inline
: constant Node_Id
:= N
;
1124 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1125 -- Returns OK on node N if this is not an extended return statement
1131 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1134 when N_Extended_Return_Statement
=>
1137 -- Skip locally declared subprogram bodies inside the body to
1138 -- inline, as the return statements inside those do not count.
1140 when N_Subprogram_Body
=>
1141 if N
= Body_To_Inline
then
1152 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1154 -- Start of processing for Has_Extended_Return
1157 return Check_All_Returns
(N
) /= OK
;
1158 end Has_Extended_Return
;
1160 -------------------------------
1161 -- Has_Pending_Instantiation --
1162 -------------------------------
1164 function Has_Pending_Instantiation
return Boolean is
1169 while Present
(S
) loop
1170 if Is_Compilation_Unit
(S
)
1171 or else Is_Child_Unit
(S
)
1175 elsif Ekind
(S
) = E_Package
1176 and then Has_Forward_Instantiation
(S
)
1185 end Has_Pending_Instantiation
;
1187 -----------------------------------------
1188 -- Has_Single_Return_In_GNATprove_Mode --
1189 -----------------------------------------
1191 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
1192 Body_To_Inline
: constant Node_Id
:= N
;
1193 Last_Statement
: Node_Id
:= Empty
;
1195 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1196 -- Returns OK on node N if this is not a return statement different
1197 -- from the last statement in the subprogram.
1203 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1206 when N_Extended_Return_Statement
1207 | N_Simple_Return_Statement
1209 if N
= Last_Statement
then
1215 -- Skip locally declared subprogram bodies inside the body to
1216 -- inline, as the return statements inside those do not count.
1218 when N_Subprogram_Body
=>
1219 if N
= Body_To_Inline
then
1230 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1232 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1235 -- Retrieve the last statement
1237 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
1239 -- Check that the last statement is the only possible return
1240 -- statement in the subprogram.
1242 return Check_All_Returns
(N
) = OK
;
1243 end Has_Single_Return_In_GNATprove_Mode
;
1245 --------------------------
1246 -- Uses_Secondary_Stack --
1247 --------------------------
1249 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
1250 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
1251 -- Look for function calls that return an unconstrained type
1257 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
1259 if Nkind
(N
) = N_Function_Call
1260 and then Is_Entity_Name
(Name
(N
))
1261 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
1262 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
1265 ("cannot inline & (call returns unconstrained type)?",
1273 function Check_Calls
is new Traverse_Func
(Check_Call
);
1276 return Check_Calls
(Bod
) = Abandon
;
1277 end Uses_Secondary_Stack
;
1279 -- Start of processing for Build_Body_To_Inline
1282 -- Return immediately if done already
1284 if Nkind
(Decl
) = N_Subprogram_Declaration
1285 and then Present
(Body_To_Inline
(Decl
))
1289 -- Subprograms that have return statements in the middle of the body are
1290 -- inlined with gotos. GNATprove does not currently support gotos, so
1291 -- we prevent such inlining.
1293 elsif GNATprove_Mode
1294 and then not Has_Single_Return_In_GNATprove_Mode
1296 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1299 -- Functions that return controlled types cannot currently be inlined
1300 -- because they require secondary stack handling; controlled actions
1301 -- may also interfere in complex ways with inlining.
1303 elsif Ekind
(Spec_Id
) = E_Function
1304 and then Needs_Finalization
(Etype
(Spec_Id
))
1307 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1311 if Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
)) then
1315 if Present
(Handled_Statement_Sequence
(N
)) then
1316 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1318 ("cannot inline& (exception handler)?",
1319 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1323 elsif Has_Excluded_Statement
1324 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1330 -- We do not inline a subprogram that is too large, unless it is marked
1331 -- Inline_Always or we are in GNATprove mode. This pragma does not
1332 -- suppress the other checks on inlining (forbidden declarations,
1335 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1336 and then List_Length
1337 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1339 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1343 if Has_Pending_Instantiation
then
1345 ("cannot inline& (forward instance within enclosing body)?",
1350 -- Within an instance, the body to inline must be treated as a nested
1351 -- generic, so that the proper global references are preserved.
1353 -- Note that we do not do this at the library level, because it is not
1354 -- needed, and furthermore this causes trouble if front-end inlining
1355 -- is activated (-gnatN).
1357 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1358 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1359 Original_Body
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
1361 Original_Body
:= Copy_Separate_Tree
(N
);
1364 -- We need to capture references to the formals in order to substitute
1365 -- the actuals at the point of inlining, i.e. instantiation. To treat
1366 -- the formals as globals to the body to inline, we nest it within a
1367 -- dummy parameterless subprogram, declared within the real one. To
1368 -- avoid generating an internal name (which is never public, and which
1369 -- affects serial numbers of other generated names), we use an internal
1370 -- symbol that cannot conflict with user declarations.
1372 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1373 Set_Defining_Unit_Name
1374 (Specification
(Original_Body
),
1375 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1376 Set_Corresponding_Spec
(Original_Body
, Empty
);
1378 -- Remove all aspects/pragmas that have no meaning in an inlined body
1380 Remove_Aspects_And_Pragmas
(Original_Body
);
1383 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
1385 -- Set return type of function, which is also global and does not need
1388 if Ekind
(Spec_Id
) = E_Function
then
1389 Set_Result_Definition
1390 (Specification
(Body_To_Analyze
),
1391 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1394 if No
(Declarations
(N
)) then
1395 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1397 Append
(Body_To_Analyze
, Declarations
(N
));
1402 Analyze
(Body_To_Analyze
);
1403 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1404 Save_Global_References
(Original_Body
);
1406 Remove
(Body_To_Analyze
);
1410 -- Restore environment if previously saved
1412 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1416 -- Functions that return unconstrained composite types require
1417 -- secondary stack handling, and cannot currently be inlined, unless
1418 -- all return statements return a local variable that is the first
1419 -- local declaration in the body. We had to delay this check until
1420 -- the body of the function is analyzed since Has_Single_Return()
1421 -- requires a minimum decoration.
1423 if Ekind
(Spec_Id
) = E_Function
1424 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1425 and then not Is_Access_Type
(Etype
(Spec_Id
))
1426 and then not Is_Constrained
(Etype
(Spec_Id
))
1428 if not Has_Single_Return
(Body_To_Analyze
)
1430 -- Skip inlining if the function returns an unconstrained type
1431 -- using an extended return statement, since this part of the
1432 -- new inlining model is not yet supported by the current
1435 or else (Returns_Unconstrained_Type
(Spec_Id
)
1436 and then Has_Extended_Return
)
1439 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1443 -- If secondary stack is used, there is no point in inlining. We have
1444 -- already issued the warning in this case, so nothing to do.
1446 elsif Uses_Secondary_Stack
(Body_To_Analyze
) then
1450 Set_Body_To_Inline
(Decl
, Original_Body
);
1451 Mutate_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1452 Set_Is_Inlined
(Spec_Id
);
1453 end Build_Body_To_Inline
;
1455 -------------------------------------------
1456 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1457 -------------------------------------------
1459 function Call_Can_Be_Inlined_In_GNATprove_Mode
1461 Subp
: Entity_Id
) return Boolean
1463 function Has_Dereference
(N
: Node_Id
) return Boolean;
1464 -- Return whether N contains an explicit dereference
1466 ---------------------
1467 -- Has_Dereference --
1468 ---------------------
1470 function Has_Dereference
(N
: Node_Id
) return Boolean is
1472 function Process
(N
: Node_Id
) return Traverse_Result
;
1473 -- Process one node in search for dereference
1479 function Process
(N
: Node_Id
) return Traverse_Result
is
1481 if Nkind
(N
) = N_Explicit_Dereference
then
1488 function Traverse
is new Traverse_Func
(Process
);
1489 -- Traverse tree to look for dereference
1492 return Traverse
(N
) = Abandon
;
1493 end Has_Dereference
;
1501 -- Check if inlining may lead to missing a check on type conversion of
1502 -- input parameters otherwise.
1504 F
:= First_Formal
(Subp
);
1505 A
:= First_Actual
(N
);
1506 while Present
(F
) loop
1507 if Ekind
(F
) /= E_Out_Parameter
1508 and then not Same_Type
(Etype
(F
), Etype
(A
))
1510 (Is_By_Reference_Type
(Etype
(A
))
1511 or else Is_Limited_Type
(Etype
(A
)))
1520 -- Check if inlining may lead to introducing temporaries of access type,
1521 -- which can lead to missing checks for memory leaks. This can only
1522 -- come from an (IN-)OUT parameter transformed into a renaming by SPARK
1523 -- expansion, whose side-effects are removed, and a dereference in the
1524 -- corresponding actual. If the formal itself is of a deep type (it has
1525 -- access subcomponents), the subprogram already cannot be inlined in
1528 F
:= First_Formal
(Subp
);
1529 A
:= First_Actual
(N
);
1530 while Present
(F
) loop
1531 if Ekind
(F
) /= E_In_Parameter
1532 and then Has_Dereference
(A
)
1542 end Call_Can_Be_Inlined_In_GNATprove_Mode
;
1544 --------------------------------------
1545 -- Can_Be_Inlined_In_GNATprove_Mode --
1546 --------------------------------------
1548 function Can_Be_Inlined_In_GNATprove_Mode
1549 (Spec_Id
: Entity_Id
;
1550 Body_Id
: Entity_Id
) return Boolean
1552 function Has_Formal_Or_Result_Of_Deep_Type
1553 (Id
: Entity_Id
) return Boolean;
1554 -- Returns true if the subprogram has at least one formal parameter or
1555 -- a return type of a deep type: either an access type or a composite
1556 -- type containing an access type.
1558 function Has_Formal_With_Per_Object_Constrained_Component
1559 (Id
: Entity_Id
) return Boolean;
1560 -- Returns true if the subprogram has at least one formal parameter of
1561 -- an unconstrained record type with per-object constraints on component
1564 function Has_Hide_Unhide_Annotation
1565 (Spec_Id
, Body_Id
: Entity_Id
)
1567 -- Returns whether the subprogram has an annotation Hide_Info or
1568 -- Unhide_Info on its spec or body.
1570 function Has_Skip_Proof_Annotation
(Id
: Entity_Id
) return Boolean;
1571 -- Returns True if subprogram Id has an annotation Skip_Proof or
1572 -- Skip_Flow_And_Proof.
1574 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1575 -- Return True if subprogram Id has any contract. The presence of
1576 -- Extensions_Visible or Volatile_Function is also considered as a
1579 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1580 -- Return True if subprogram Id defines a compilation unit
1582 function In_Package_Spec
(Id
: Entity_Id
) return Boolean;
1583 -- Return True if subprogram Id is defined in the package specification,
1584 -- either its visible or private part.
1586 function Maybe_Traversal_Function
(Id
: Entity_Id
) return Boolean;
1587 -- Return True if subprogram Id could be a traversal function, as
1588 -- defined in SPARK RM 3.10. This is only a safe approximation, as the
1589 -- knowledge of the SPARK boundary is needed to determine exactly
1590 -- traversal functions.
1592 ---------------------------------------
1593 -- Has_Formal_Or_Result_Of_Deep_Type --
1594 ---------------------------------------
1596 function Has_Formal_Or_Result_Of_Deep_Type
1597 (Id
: Entity_Id
) return Boolean
1599 function Is_Deep
(Typ
: Entity_Id
) return Boolean;
1600 -- Return True if Typ is deep: either an access type or a composite
1601 -- type containing an access type.
1607 function Is_Deep
(Typ
: Entity_Id
) return Boolean is
1609 case Type_Kind
'(Ekind (Typ)) is
1616 return Is_Deep (Component_Type (Typ));
1620 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
1622 while Present (Comp) loop
1623 if Is_Deep (Etype (Comp)) then
1626 Next_Component_Or_Discriminant (Comp);
1632 | E_String_Literal_Subtype
1642 | E_Limited_Private_Type
1643 | E_Limited_Private_Subtype
1645 -- Conservatively consider that the type might be deep if
1646 -- its completion has not been seen yet.
1648 if No (Underlying_Type (Typ)) then
1651 -- Do not peek under a private type if its completion has
1652 -- SPARK_Mode Off. In such a case, a deep type is considered
1653 -- by GNATprove to be not deep.
1655 elsif Present (Full_View (Typ))
1656 and then Present (SPARK_Pragma (Full_View (Typ)))
1657 and then Get_SPARK_Mode_From_Annotation
1658 (SPARK_Pragma (Full_View (Typ))) = Off
1662 -- Otherwise peek under the private type.
1665 return Is_Deep (Underlying_Type (Typ));
1672 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1674 Formal_Typ : Entity_Id;
1676 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
1679 -- Inspect all parameters of the subprogram looking for a formal
1682 Formal := First_Formal (Subp_Id);
1683 while Present (Formal) loop
1684 Formal_Typ := Etype (Formal);
1686 if Is_Deep (Formal_Typ) then
1690 Next_Formal (Formal);
1693 -- Check whether this is a function whose return type is deep
1695 if Ekind (Subp_Id) = E_Function
1696 and then Is_Deep (Etype (Subp_Id))
1702 end Has_Formal_Or_Result_Of_Deep_Type;
1704 ------------------------------------------------------
1705 -- Has_Formal_With_Per_Object_Constrained_Component --
1706 ------------------------------------------------------
1708 function Has_Formal_With_Per_Object_Constrained_Component
1709 (Id : Entity_Id) return Boolean
1711 function Has_Per_Object_Constrained_Component
1712 (Typ : Entity_Id) return Boolean;
1713 -- Determine whether unconstrained record type Typ has at least one
1714 -- component that depends on a discriminant.
1716 ------------------------------------------
1717 -- Has_Per_Object_Constrained_Component --
1718 ------------------------------------------
1720 function Has_Per_Object_Constrained_Component
1721 (Typ : Entity_Id) return Boolean
1726 -- Inspect all components of the record type looking for one that
1727 -- depends on a discriminant.
1729 Comp := First_Component (Typ);
1730 while Present (Comp) loop
1731 if Has_Per_Object_Constraint (Comp) then
1735 Next_Component (Comp);
1739 end Has_Per_Object_Constrained_Component;
1743 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1745 Formal_Typ : Entity_Id;
1747 -- Start of processing for
1748 -- Has_Formal_With_Per_Object_Constrained_Component
1751 -- Inspect all parameters of the subprogram looking for a formal
1752 -- of an unconstrained record type with at least one discriminant
1753 -- dependent component.
1755 Formal := First_Formal (Subp_Id);
1756 while Present (Formal) loop
1757 Formal_Typ := Etype (Formal);
1759 if Is_Record_Type (Formal_Typ)
1760 and then not Is_Constrained (Formal_Typ)
1761 and then Has_Per_Object_Constrained_Component (Formal_Typ)
1766 Next_Formal (Formal);
1770 end Has_Formal_With_Per_Object_Constrained_Component;
1772 --------------------------------
1773 -- Has_Hide_Unhide_Annotation --
1774 --------------------------------
1776 function Has_Hide_Unhide_Annotation
1777 (Spec_Id, Body_Id : Entity_Id)
1780 function Has_Hide_Unhide_Pragma (Prag : Node_Id) return Boolean;
1781 -- Return whether a pragma Hide/Unhide is present in the list of
1782 -- pragmas starting with Prag.
1784 ----------------------------
1785 -- Has_Hide_Unhide_Pragma --
1786 ----------------------------
1788 function Has_Hide_Unhide_Pragma (Prag : Node_Id) return Boolean is
1789 Decl : Node_Id := Prag;
1791 while Present (Decl)
1792 and then Nkind (Decl) = N_Pragma
1794 if Get_Pragma_Id (Decl) = Pragma_Annotate
1795 and then List_Length (Pragma_Argument_Associations (Decl)) = 4
1798 Arg1 : constant Node_Id :=
1799 First (Pragma_Argument_Associations (Decl));
1800 Arg2 : constant Node_Id := Next (Arg1);
1801 Arg1_Name : constant Name_Id :=
1802 Chars (Get_Pragma_Arg (Arg1));
1803 Arg2_Name : constant String :=
1804 Get_Name_String (Chars (Get_Pragma_Arg (Arg2)));
1806 if Arg1_Name = Name_Gnatprove
1807 and then Arg2_Name in "hide_info" | "unhide_info"
1818 end Has_Hide_Unhide_Pragma;
1821 if Present (Spec_Id)
1822 and then Is_List_Member (Unit_Declaration_Node (Spec_Id))
1823 and then Has_Hide_Unhide_Pragma
1824 (Next (Unit_Declaration_Node (Spec_Id)))
1828 elsif Present (Body_Id) then
1830 Subp_Body : constant N_Subprogram_Body_Id :=
1831 Unit_Declaration_Node (Body_Id);
1834 (Is_List_Member (Subp_Body)
1835 and then Has_Hide_Unhide_Pragma (Next (Subp_Body)))
1837 Has_Hide_Unhide_Pragma (First (Declarations (Subp_Body)));
1843 end Has_Hide_Unhide_Annotation;
1845 -------------------------------
1846 -- Has_Skip_Proof_Annotation --
1847 -------------------------------
1849 function Has_Skip_Proof_Annotation (Id : Entity_Id) return Boolean is
1850 Decl : Node_Id := Unit_Declaration_Node (Id);
1855 while Present (Decl)
1856 and then Nkind (Decl) = N_Pragma
1858 if Get_Pragma_Id (Decl) = Pragma_Annotate
1859 and then List_Length (Pragma_Argument_Associations (Decl)) = 3
1862 Arg1 : constant Node_Id :=
1863 First (Pragma_Argument_Associations (Decl));
1864 Arg2 : constant Node_Id := Next (Arg1);
1865 Arg1_Name : constant Name_Id :=
1866 Chars (Get_Pragma_Arg (Arg1));
1867 Arg2_Name : constant String :=
1868 Get_Name_String (Chars (Get_Pragma_Arg (Arg2)));
1870 if Arg1_Name = Name_Gnatprove
1871 and then Arg2_Name in "skip_proof" | "skip_flow_and_proof"
1882 end Has_Skip_Proof_Annotation;
1884 -----------------------
1885 -- Has_Some_Contract --
1886 -----------------------
1888 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1892 -- A call to an expression function may precede the actual body which
1893 -- is inserted at the end of the enclosing declarations. Ensure that
1894 -- the related entity is decorated before inspecting the contract.
1896 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1897 Items := Contract (Id);
1899 -- Note that Classifications is not Empty when Extensions_Visible
1900 -- or Volatile_Function is present, which causes such subprograms
1901 -- to be considered to have a contract here. This is fine as we
1902 -- want to avoid inlining these too.
1904 return Present (Items)
1905 and then (Present (Pre_Post_Conditions (Items)) or else
1906 Present (Contract_Test_Cases (Items)) or else
1907 Present (Classifications (Items)));
1911 end Has_Some_Contract;
1913 ---------------------
1914 -- In_Package_Spec --
1915 ---------------------
1917 function In_Package_Spec (Id : Entity_Id) return Boolean is
1918 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1919 -- Parent of the subprogram's declaration
1922 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1923 end In_Package_Spec;
1925 ------------------------
1926 -- Is_Unit_Subprogram --
1927 ------------------------
1929 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1930 Decl : Node_Id := Parent (Parent (Id));
1932 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1933 Decl := Parent (Decl);
1936 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1937 end Is_Unit_Subprogram;
1939 ------------------------------
1940 -- Maybe_Traversal_Function --
1941 ------------------------------
1943 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
1945 return Ekind (Id) = E_Function
1947 -- Only traversal functions return an anonymous access-to-object
1950 and then Is_Anonymous_Access_Type (Etype (Id));
1951 end Maybe_Traversal_Function;
1953 -- Local declarations
1956 -- Procedure or function entity for the subprogram
1958 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1961 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1963 if Present (Spec_Id) then
1969 -- Only local subprograms without contracts are inlined in GNATprove
1970 -- mode, as these are the subprograms which a user is not interested in
1971 -- analyzing in isolation, but rather in the context of their call. This
1972 -- is a convenient convention, that could be changed for an explicit
1973 -- pragma/aspect one day.
1975 -- In a number of special cases, inlining is not desirable or not
1976 -- possible, see below.
1978 -- Do not inline unit-level subprograms
1980 if Is_Unit_Subprogram (Id) then
1983 -- Do not inline subprograms declared in package specs, because they are
1984 -- not local, i.e. can be called either from anywhere (if declared in
1985 -- visible part) or from the child units (if declared in private part).
1987 elsif In_Package_Spec (Id) then
1990 -- Do not inline subprograms declared in other units. This is important
1991 -- in particular for subprograms defined in the private part of a
1992 -- package spec, when analyzing one of its child packages, as otherwise
1993 -- we issue spurious messages about the impossibility to inline such
1996 elsif not In_Extended_Main_Code_Unit (Id) then
1999 -- Do not inline dispatching operations, as only their static calls
2000 -- can be analyzed in context, and not their dispatching calls.
2002 elsif Is_Dispatching_Operation (Id) then
2005 -- Do not inline subprograms marked No_Return, possibly used for
2006 -- signaling errors, which GNATprove handles specially.
2008 elsif No_Return (Id) then
2011 -- Do not inline subprograms that have a contract on the spec or the
2012 -- body. Use the contract(s) instead in GNATprove. This also prevents
2013 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
2015 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
2017 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
2021 -- Do not inline expression functions, which are directly inlined at the
2024 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
2026 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
2030 -- Do not inline generic subprogram instances. The visibility rules of
2031 -- generic instances plays badly with inlining.
2033 elsif Is_Generic_Instance (Spec_Id) then
2036 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
2037 -- the subprogram body, a similar check is performed after the body
2038 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
2040 elsif Present (Spec_Id)
2042 (No (SPARK_Pragma (Spec_Id))
2044 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
2048 -- Do not inline subprograms and entries defined inside protected types,
2049 -- which typically are not helper subprograms, which also avoids getting
2050 -- spurious messages on calls that cannot be inlined.
2052 elsif Within_Protected_Type (Id) then
2055 -- Do not inline predicate functions (treated specially by GNATprove)
2057 elsif Is_Predicate_Function (Id) then
2060 -- Do not inline subprograms with a parameter of an unconstrained
2061 -- record type if it has discrimiant dependent fields. Indeed, with
2062 -- such parameters, the frontend cannot always ensure type compliance
2063 -- in record component accesses (in particular with records containing
2066 elsif Has_Formal_With_Per_Object_Constrained_Component (Id) then
2069 -- Do not inline subprograms with a formal parameter or return type of
2070 -- a deep type, as in that case inlining might generate code that
2071 -- violates borrow-checking rules of SPARK 3.10 even if the original
2074 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
2077 -- Do not inline subprograms which may be traversal functions. Such
2078 -- inlining introduces temporary variables of named access type for
2079 -- which assignments are move instead of borrow/observe, possibly
2080 -- leading to spurious errors when checking SPARK rules related to
2083 elsif Maybe_Traversal_Function (Id) then
2086 -- Do not inline subprograms with the Skip_Proof or Skip_Flow_And_Proof
2087 -- annotation, which should be handled separately.
2089 elsif Has_Skip_Proof_Annotation (Id) then
2092 -- Do not inline subprograms with the Hide_Info or Unhide_Info
2093 -- annotation, since their scope has special visibility on the
2094 -- precise definition of some entities.
2096 elsif Has_Hide_Unhide_Annotation (Spec_Id, Body_Id) then
2099 -- Otherwise, this is a subprogram declared inside the private part of a
2100 -- package, or inside a package body, or locally in a subprogram, and it
2101 -- does not have any contract. Inline it.
2106 end Can_Be_Inlined_In_GNATprove_Mode;
2112 procedure Cannot_Inline
2116 Is_Serious : Boolean := False;
2117 Suppress_Info : Boolean := False)
2120 -- In GNATprove mode, inlining is the technical means by which the
2121 -- higher-level goal of contextual analysis is reached, so issue
2122 -- messages about failure to apply contextual analysis to a
2123 -- subprogram, rather than failure to inline it.
2126 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
2129 Len1 : constant Positive :=
2130 String'("cannot inline")'Length;
2131 Len2
: constant Positive :=
2132 String'("info: no contextual analysis of")'Length;
2134 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
2137 New_Msg (1 .. Len2) := "info: no contextual analysis of";
2138 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
2139 Msg (Msg'First + Len1 .. Msg'Last);
2140 Cannot_Inline (New_Msg, N, Subp, Is_Serious, Suppress_Info);
2145 pragma Assert (Msg (Msg'Last) = '?
');
2147 -- Legacy front-end inlining model
2149 if not Back_End_Inlining then
2151 -- Do not emit warning if this is a predefined unit which is not
2152 -- the main unit. With validity checks enabled, some predefined
2153 -- subprograms may contain nested subprograms and become ineligible
2156 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2157 and then not In_Extended_Main_Source_Unit (Subp)
2161 -- In GNATprove mode, issue an info message when -gnatd_f is set and
2162 -- Suppress_Info is False, and indicate that the subprogram is not
2163 -- always inlined by setting flag Is_Inlined_Always to False.
2165 elsif GNATprove_Mode then
2166 Set_Is_Inlined_Always (Subp, False);
2168 if Debug_Flag_Underscore_F and not Suppress_Info then
2169 Error_Msg_NE (Msg, N, Subp);
2172 elsif Has_Pragma_Inline_Always (Subp) then
2174 -- Remove last character (question mark) to make this into an
2175 -- error, because the Inline_Always pragma cannot be obeyed.
2177 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2179 elsif Ineffective_Inline_Warnings then
2180 Error_Msg_NE (Msg & "p?", N, Subp);
2183 -- New semantics relying on back-end inlining
2185 elsif Is_Serious then
2187 -- Remove last character (question mark) to make this into an error.
2189 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2193 -- Do not emit warning if this is a predefined unit which is not
2194 -- the main unit. This behavior is currently provided for backward
2195 -- compatibility but it will be removed when we enforce the
2196 -- strictness of the new rules.
2198 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2199 and then not In_Extended_Main_Source_Unit (Subp)
2203 elsif Has_Pragma_Inline_Always (Subp) then
2205 -- Emit a warning if this is a call to a runtime subprogram
2206 -- which is located inside a generic. Previously this call
2207 -- was silently skipped.
2209 if Is_Generic_Instance (Subp) then
2211 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
2213 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
2214 Set_Is_Inlined (Subp, False);
2215 Error_Msg_NE (Msg & "p?", N, Subp);
2221 -- Remove last character (question mark) to make this into an
2222 -- error, because the Inline_Always pragma cannot be obeyed.
2224 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2227 Set_Is_Inlined (Subp, False);
2229 if Ineffective_Inline_Warnings then
2230 Error_Msg_NE (Msg & "p?", N, Subp);
2236 --------------------------------------------
2237 -- Check_And_Split_Unconstrained_Function --
2238 --------------------------------------------
2240 procedure Check_And_Split_Unconstrained_Function
2242 Spec_Id : Entity_Id;
2243 Body_Id : Entity_Id)
2245 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
2246 -- Use generic machinery to build an unexpanded body for the subprogram.
2247 -- This body is subsequently used for inline expansions at call sites.
2249 procedure Build_Return_Object_Formal
2253 -- Create a formal parameter for return object declaration Obj_Decl of
2254 -- an extended return statement and add it to list Formals.
2256 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
2257 -- Return true if we generate code for the function body N, the function
2258 -- body N has no local declarations and its unique statement is a single
2259 -- extended return statement with a handled statements sequence.
2261 procedure Copy_Formals
2263 Subp_Id : Entity_Id;
2265 -- Create new formal parameters from the formal parameters of subprogram
2266 -- Subp_Id and add them to list Formals.
2268 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
2269 -- Create a copy of return object declaration Obj_Decl of an extended
2270 -- return statement.
2272 procedure Split_Unconstrained_Function
2274 Spec_Id : Entity_Id);
2275 -- N is an inlined function body that returns an unconstrained type and
2276 -- has a single extended return statement. Split N in two subprograms:
2277 -- a procedure P' and a
function F
'. The formals of P' duplicate the
2278 -- formals of N plus an extra formal which is used to return a value;
2279 -- its body is composed by the declarations and list of statements
2280 -- of the extended return statement of N.
2282 --------------------------
2283 -- Build_Body_To_Inline --
2284 --------------------------
2286 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2287 procedure Generate_Subprogram_Body
2289 Body_To_Inline
: out Node_Id
);
2290 -- Generate a parameterless duplicate of subprogram body N. Note that
2291 -- occurrences of pragmas referencing the formals are removed since
2292 -- they have no meaning when the body is inlined and the formals are
2293 -- rewritten (the analysis of the non-inlined body will handle these
2294 -- pragmas). A new internal name is associated with Body_To_Inline.
2296 ------------------------------
2297 -- Generate_Subprogram_Body --
2298 ------------------------------
2300 procedure Generate_Subprogram_Body
2302 Body_To_Inline
: out Node_Id
)
2305 -- Within an instance, the body to inline must be treated as a
2306 -- nested generic so that proper global references are preserved.
2308 -- Note that we do not do this at the library level, because it
2309 -- is not needed, and furthermore this causes trouble if front
2310 -- end inlining is activated (-gnatN).
2313 and then Scope
(Current_Scope
) /= Standard_Standard
2316 Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
2318 Body_To_Inline
:= New_Copy_Tree
(N
);
2321 -- Remove aspects/pragmas that have no meaning in an inlined body
2323 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
2325 -- We need to capture references to the formals in order
2326 -- to substitute the actuals at the point of inlining, i.e.
2327 -- instantiation. To treat the formals as globals to the body to
2328 -- inline, we nest it within a dummy parameterless subprogram,
2329 -- declared within the real one.
2331 Set_Parameter_Specifications
2332 (Specification
(Body_To_Inline
), No_List
);
2334 -- A new internal name is associated with Body_To_Inline to avoid
2335 -- conflicts when the non-inlined body N is analyzed.
2337 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
2338 Make_Temporary
(Sloc
(N
), 'P'));
2339 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
2340 end Generate_Subprogram_Body
;
2344 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2345 Original_Body
: Node_Id
;
2346 Body_To_Analyze
: Node_Id
;
2348 -- Start of processing for Build_Body_To_Inline
2351 pragma Assert
(Current_Scope
= Spec_Id
);
2353 -- Within an instance, the body to inline must be treated as a nested
2354 -- generic, so that the proper global references are preserved. We
2355 -- do not do this at the library level, because it is not needed, and
2356 -- furthermore this causes trouble if front-end inlining is activated
2360 and then Scope
(Current_Scope
) /= Standard_Standard
2362 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
2365 -- Capture references to formals in order to substitute the actuals
2366 -- at the point of inlining or instantiation. To treat the formals
2367 -- as globals to the body to inline, nest the body within a dummy
2368 -- parameterless subprogram, declared within the real one.
2370 Generate_Subprogram_Body
(N
, Original_Body
);
2372 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
2374 -- Set return type of function, which is also global and does not
2375 -- need to be resolved.
2377 if Ekind
(Spec_Id
) = E_Function
then
2378 Set_Result_Definition
(Specification
(Body_To_Analyze
),
2379 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
2382 if No
(Declarations
(N
)) then
2383 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
2385 Append_To
(Declarations
(N
), Body_To_Analyze
);
2388 Preanalyze
(Body_To_Analyze
);
2390 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
2391 Save_Global_References
(Original_Body
);
2393 Remove
(Body_To_Analyze
);
2395 -- Restore environment if previously saved
2398 and then Scope
(Current_Scope
) /= Standard_Standard
2403 pragma Assert
(No
(Body_To_Inline
(Decl
)));
2404 Set_Body_To_Inline
(Decl
, Original_Body
);
2405 Mutate_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
2406 end Build_Body_To_Inline
;
2408 --------------------------------
2409 -- Build_Return_Object_Formal --
2410 --------------------------------
2412 procedure Build_Return_Object_Formal
2417 Obj_Def
: constant Node_Id
:= Object_Definition
(Obj_Decl
);
2418 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2422 -- Build the type definition of the formal parameter. The use of
2423 -- New_Copy_Tree ensures that global references preserved in the
2424 -- case of generics.
2426 if Is_Entity_Name
(Obj_Def
) then
2427 Typ_Def
:= New_Copy_Tree
(Obj_Def
);
2429 Typ_Def
:= New_Copy_Tree
(Subtype_Mark
(Obj_Def
));
2434 -- Obj_Id : [out] Typ_Def
2436 -- Mode OUT should not be used when the return object is declared as
2437 -- a constant. Check the definition of the object declaration because
2438 -- the object has not been analyzed yet.
2441 Make_Parameter_Specification
(Loc
,
2442 Defining_Identifier
=>
2443 Make_Defining_Identifier
(Loc
, Chars
(Obj_Id
)),
2444 In_Present
=> False,
2445 Out_Present
=> not Constant_Present
(Obj_Decl
),
2446 Null_Exclusion_Present
=> False,
2447 Parameter_Type
=> Typ_Def
));
2448 end Build_Return_Object_Formal
;
2450 --------------------------------------
2451 -- Can_Split_Unconstrained_Function --
2452 --------------------------------------
2454 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean is
2455 Stmt
: constant Node_Id
:=
2456 First
(Statements
(Handled_Statement_Sequence
(N
)));
2460 -- No user defined declarations allowed in the function except inside
2461 -- the unique return statement; implicit labels are the only allowed
2464 Decl
:= First
(Declarations
(N
));
2465 while Present
(Decl
) loop
2466 if Nkind
(Decl
) /= N_Implicit_Label_Declaration
then
2473 -- We only split the inlined function when we are generating the code
2474 -- of its body; otherwise we leave duplicated split subprograms in
2475 -- the tree which (if referenced) generate wrong references at link
2478 return In_Extended_Main_Code_Unit
(N
)
2479 and then Present
(Stmt
)
2480 and then Nkind
(Stmt
) = N_Extended_Return_Statement
2481 and then No
(Next
(Stmt
))
2482 and then Present
(Handled_Statement_Sequence
(Stmt
));
2483 end Can_Split_Unconstrained_Function
;
2489 procedure Copy_Formals
2491 Subp_Id
: Entity_Id
;
2498 Formal
:= First_Formal
(Subp_Id
);
2499 while Present
(Formal
) loop
2500 Spec
:= Parent
(Formal
);
2502 -- Create an exact copy of the formal parameter. The use of
2503 -- New_Copy_Tree ensures that global references are preserved
2504 -- in case of generics.
2507 Make_Parameter_Specification
(Loc
,
2508 Defining_Identifier
=>
2509 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
2510 In_Present
=> In_Present
(Spec
),
2511 Out_Present
=> Out_Present
(Spec
),
2512 Null_Exclusion_Present
=> Null_Exclusion_Present
(Spec
),
2514 New_Copy_Tree
(Parameter_Type
(Spec
)),
2515 Expression
=> New_Copy_Tree
(Expression
(Spec
))));
2517 Next_Formal
(Formal
);
2521 ------------------------
2522 -- Copy_Return_Object --
2523 ------------------------
2525 function Copy_Return_Object
(Obj_Decl
: Node_Id
) return Node_Id
is
2526 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2529 -- The use of New_Copy_Tree ensures that global references are
2530 -- preserved in case of generics.
2533 Make_Object_Declaration
(Sloc
(Obj_Decl
),
2534 Defining_Identifier
=>
2535 Make_Defining_Identifier
(Sloc
(Obj_Id
), Chars
(Obj_Id
)),
2536 Aliased_Present
=> Aliased_Present
(Obj_Decl
),
2537 Constant_Present
=> Constant_Present
(Obj_Decl
),
2538 Null_Exclusion_Present
=> Null_Exclusion_Present
(Obj_Decl
),
2539 Object_Definition
=>
2540 New_Copy_Tree
(Object_Definition
(Obj_Decl
)),
2541 Expression
=> New_Copy_Tree
(Expression
(Obj_Decl
)));
2542 end Copy_Return_Object
;
2544 ----------------------------------
2545 -- Split_Unconstrained_Function --
2546 ----------------------------------
2548 procedure Split_Unconstrained_Function
2550 Spec_Id
: Entity_Id
)
2552 Loc
: constant Source_Ptr
:= Sloc
(N
);
2553 Ret_Stmt
: constant Node_Id
:=
2554 First
(Statements
(Handled_Statement_Sequence
(N
)));
2555 Ret_Obj
: constant Node_Id
:=
2556 First
(Return_Object_Declarations
(Ret_Stmt
));
2558 procedure Build_Procedure
2559 (Proc_Id
: out Entity_Id
;
2560 Decl_List
: out List_Id
);
2561 -- Build a procedure containing the statements found in the extended
2562 -- return statement of the unconstrained function body N.
2564 ---------------------
2565 -- Build_Procedure --
2566 ---------------------
2568 procedure Build_Procedure
2569 (Proc_Id
: out Entity_Id
;
2570 Decl_List
: out List_Id
)
2572 Formals
: constant List_Id
:= New_List
;
2573 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
2575 Body_Decls
: List_Id
:= No_List
;
2577 Proc_Body
: Node_Id
;
2578 Proc_Spec
: Node_Id
;
2581 -- Create formal parameters for the return object and all formals
2582 -- of the unconstrained function in order to pass their values to
2585 Build_Return_Object_Formal
2587 Obj_Decl
=> Ret_Obj
,
2588 Formals
=> Formals
);
2593 Formals
=> Formals
);
2595 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
2598 Make_Procedure_Specification
(Loc
,
2599 Defining_Unit_Name
=> Proc_Id
,
2600 Parameter_Specifications
=> Formals
);
2602 Decl_List
:= New_List
;
2604 Append_To
(Decl_List
,
2605 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
2607 -- Can_Convert_Unconstrained_Function checked that the function
2608 -- has no local declarations except implicit label declarations.
2609 -- Copy these declarations to the built procedure.
2611 if Present
(Declarations
(N
)) then
2612 Body_Decls
:= New_List
;
2614 Decl
:= First
(Declarations
(N
));
2615 while Present
(Decl
) loop
2616 pragma Assert
(Nkind
(Decl
) = N_Implicit_Label_Declaration
);
2618 Append_To
(Body_Decls
,
2619 Make_Implicit_Label_Declaration
(Loc
,
2620 Make_Defining_Identifier
(Loc
,
2621 Chars
=> Chars
(Defining_Identifier
(Decl
))),
2622 Label_Construct
=> Empty
));
2628 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Stmt
)));
2631 Make_Subprogram_Body
(Loc
,
2632 Specification
=> Copy_Subprogram_Spec
(Proc_Spec
),
2633 Declarations
=> Body_Decls
,
2634 Handled_Statement_Sequence
=>
2635 New_Copy_Tree
(Handled_Statement_Sequence
(Ret_Stmt
)));
2637 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
2638 Make_Defining_Identifier
(Loc
, Subp_Name
));
2640 Append_To
(Decl_List
, Proc_Body
);
2641 end Build_Procedure
;
2645 New_Obj
: constant Node_Id
:= Copy_Return_Object
(Ret_Obj
);
2647 Proc_Call
: Node_Id
;
2648 Proc_Id
: Entity_Id
;
2650 -- Start of processing for Split_Unconstrained_Function
2653 -- Build the associated procedure, analyze it and insert it before
2654 -- the function body N.
2657 Scope
: constant Entity_Id
:= Current_Scope
;
2658 Decl_List
: List_Id
;
2661 Build_Procedure
(Proc_Id
, Decl_List
);
2662 Insert_Actions
(N
, Decl_List
);
2663 Set_Is_Inlined
(Proc_Id
);
2667 -- Build the call to the generated procedure
2670 Actual_List
: constant List_Id
:= New_List
;
2674 Append_To
(Actual_List
,
2675 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
2677 Formal
:= First_Formal
(Spec_Id
);
2678 while Present
(Formal
) loop
2679 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
2681 -- Avoid spurious warning on unreferenced formals
2683 Set_Referenced
(Formal
);
2684 Next_Formal
(Formal
);
2688 Make_Procedure_Call_Statement
(Loc
,
2689 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
2690 Parameter_Associations
=> Actual_List
);
2698 -- Proc (New_Obj, ...);
2703 Make_Block_Statement
(Loc
,
2704 Declarations
=> New_List
(New_Obj
),
2705 Handled_Statement_Sequence
=>
2706 Make_Handled_Sequence_Of_Statements
(Loc
,
2707 Statements
=> New_List
(
2711 Make_Simple_Return_Statement
(Loc
,
2714 (Defining_Identifier
(New_Obj
), Loc
)))));
2716 Rewrite
(Ret_Stmt
, Blk_Stmt
);
2717 end Split_Unconstrained_Function
;
2721 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2723 -- Start of processing for Check_And_Split_Unconstrained_Function
2726 pragma Assert
(Back_End_Inlining
2727 and then Ekind
(Spec_Id
) = E_Function
2728 and then Returns_Unconstrained_Type
(Spec_Id
)
2729 and then Comes_From_Source
(Body_Id
)
2730 and then (Has_Pragma_Inline_Always
(Spec_Id
)
2731 or else Optimization_Level
> 0));
2733 -- This routine must not be used in GNATprove mode since GNATprove
2734 -- relies on frontend inlining
2736 pragma Assert
(not GNATprove_Mode
);
2738 -- No need to split the function if we cannot generate the code
2740 if Serious_Errors_Detected
/= 0 then
2744 -- No action needed in stubs since the attribute Body_To_Inline
2747 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
2750 -- Cannot build the body to inline if the attribute is already set.
2751 -- This attribute may have been set if this is a subprogram renaming
2752 -- declarations (see Freeze.Build_Renamed_Body).
2754 elsif Present
(Body_To_Inline
(Decl
)) then
2757 -- Do not generate a body to inline for protected functions, because the
2758 -- transformation generates a call to a protected procedure, causing
2759 -- spurious errors. We don't inline protected operations anyway, so
2760 -- this is no loss. We might as well ignore intrinsics and foreign
2761 -- conventions as well -- just allow Ada conventions.
2763 elsif not (Convention
(Spec_Id
) = Convention_Ada
2764 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Copy
2765 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Reference
)
2769 -- Check excluded declarations
2771 elsif Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
)) then
2774 -- Check excluded statements. There is no need to protect us against
2775 -- exception handlers since they are supported by the GCC backend.
2777 elsif Present
(Handled_Statement_Sequence
(N
))
2778 and then Has_Excluded_Statement
2779 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2784 -- Build the body to inline only if really needed
2786 if Can_Split_Unconstrained_Function
(N
) then
2787 Split_Unconstrained_Function
(N
, Spec_Id
);
2788 Build_Body_To_Inline
(N
, Spec_Id
);
2789 Set_Is_Inlined
(Spec_Id
);
2791 end Check_And_Split_Unconstrained_Function
;
2793 ---------------------------------------------
2794 -- Check_Object_Renaming_In_GNATprove_Mode --
2795 ---------------------------------------------
2797 procedure Check_Object_Renaming_In_GNATprove_Mode
(Spec_Id
: Entity_Id
) is
2798 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2799 Body_Decl
: constant Node_Id
:=
2800 Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2802 function Check_Object_Renaming
(N
: Node_Id
) return Traverse_Result
;
2803 -- Returns Abandon on node N if this is a reference to an object
2804 -- renaming, which will be expanded into the renamed object in
2807 ---------------------------
2808 -- Check_Object_Renaming --
2809 ---------------------------
2811 function Check_Object_Renaming
(N
: Node_Id
) return Traverse_Result
is
2813 case Nkind
(Original_Node
(N
)) is
2814 when N_Expanded_Name
2818 Obj_Id
: constant Entity_Id
:= Entity
(Original_Node
(N
));
2820 -- Recognize the case when SPARK expansion rewrites a
2821 -- reference to an object renaming.
2824 and then Is_Object
(Obj_Id
)
2825 and then Present
(Renamed_Object
(Obj_Id
))
2826 and then Nkind
(Renamed_Object
(Obj_Id
)) not in N_Entity
2828 -- Copy_Generic_Node called for inlining expects the
2829 -- references to global entities to have the same kind
2830 -- in the "generic" code and its "instantiation".
2832 and then Nkind
(Original_Node
(N
)) /=
2833 Nkind
(Renamed_Object
(Obj_Id
))
2844 end Check_Object_Renaming
;
2846 function Check_All_Object_Renamings
is new
2847 Traverse_Func
(Check_Object_Renaming
);
2849 -- Start of processing for Check_Object_Renaming_In_GNATprove_Mode
2852 -- Subprograms with object renamings replaced by the special SPARK
2853 -- expansion cannot be inlined.
2855 if Check_All_Object_Renamings
(Body_Decl
) /= OK
then
2856 Cannot_Inline
("cannot inline & (object renaming)?",
2857 Body_Decl
, Spec_Id
);
2858 Set_Body_To_Inline
(Decl
, Empty
);
2860 end Check_Object_Renaming_In_GNATprove_Mode
;
2862 -------------------------------------
2863 -- Check_Package_Body_For_Inlining --
2864 -------------------------------------
2866 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2867 Bname
: Unit_Name_Type
;
2872 -- Legacy implementation (relying on frontend inlining)
2874 if not Back_End_Inlining
2875 and then Is_Compilation_Unit
(P
)
2876 and then not Is_Generic_Instance
(P
)
2878 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2880 E
:= First_Entity
(P
);
2881 while Present
(E
) loop
2882 if Has_Pragma_Inline_Always
(E
)
2883 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2885 if not Is_Loaded
(Bname
) then
2886 Load_Needed_Body
(N
, OK
);
2890 -- Check we are not trying to inline a parent whose body
2891 -- depends on a child, when we are compiling the body of
2892 -- the child. Otherwise we have a potential elaboration
2893 -- circularity with inlined subprograms and with
2894 -- Taft-Amendment types.
2897 Comp
: Node_Id
; -- Body just compiled
2898 Child_Spec
: Entity_Id
; -- Spec of main unit
2899 Ent
: Entity_Id
; -- For iteration
2900 With_Clause
: Node_Id
; -- Context of body.
2903 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2904 and then Present
(Body_Entity
(P
))
2908 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2911 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2913 -- Check whether the context of the body just
2914 -- compiled includes a child of itself, and that
2915 -- child is the spec of the main compilation.
2917 With_Clause
:= First
(Context_Items
(Comp
));
2918 while Present
(With_Clause
) loop
2919 if Nkind
(With_Clause
) = N_With_Clause
2921 Scope
(Entity
(Name
(With_Clause
))) = P
2923 Entity
(Name
(With_Clause
)) = Child_Spec
2925 Error_Msg_Node_2
:= Child_Spec
;
2927 ("body of & depends on child unit&??",
2930 ("\subprograms in body cannot be inlined??",
2933 -- Disable further inlining from this unit,
2934 -- and keep Taft-amendment types incomplete.
2936 Ent
:= First_Entity
(P
);
2937 while Present
(Ent
) loop
2939 and then Has_Completion_In_Body
(Ent
)
2941 Set_Full_View
(Ent
, Empty
);
2943 elsif Is_Subprogram
(Ent
) then
2944 Set_Is_Inlined
(Ent
, False);
2958 elsif Ineffective_Inline_Warnings
then
2959 Error_Msg_Unit_1
:= Bname
;
2961 ("unable to inline subprograms defined in $?p?", P
);
2962 Error_Msg_N
("\body not found?p?", P
);
2973 end Check_Package_Body_For_Inlining
;
2975 --------------------
2976 -- Cleanup_Scopes --
2977 --------------------
2979 procedure Cleanup_Scopes
is
2987 Elmt
:= First_Elmt
(To_Clean
);
2988 while Present
(Elmt
) loop
2989 Scop
:= Node
(Elmt
);
2990 Kind
:= Ekind
(Scop
);
2992 if Kind
= E_Block
then
2993 Decl
:= Parent
(Block_Node
(Scop
));
2996 Decl
:= Unit_Declaration_Node
(Scop
);
2998 if Nkind
(Decl
) in N_Subprogram_Declaration
2999 | N_Task_Type_Declaration
3000 | N_Subprogram_Body_Stub
3002 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
3006 -- Finalizers are built only for package specs and bodies that are
3007 -- compilation units, so check that we do not have anything else.
3008 -- Moreover, they must be built at most once for each entity during
3009 -- the compilation of the main unit. However, if other units are
3010 -- later compiled for inlining purposes, they may also contain body
3011 -- instances and, therefore, appear again here, so we need to make
3012 -- sure that we do not build two finalizers for them (note that the
3013 -- contents of the finalizer for these units is irrelevant since it
3014 -- is not output in the generated code).
3016 if Kind
in E_Package | E_Package_Body
then
3018 Unit_Entity
: constant Entity_Id
:=
3019 (if Kind
= E_Package
then Scop
else Spec_Entity
(Scop
));
3022 pragma Assert
(Is_Compilation_Unit
(Unit_Entity
)
3023 and then (No
(Finalizer
(Scop
))
3024 or else Unit_Entity
/= Main_Unit_Entity
));
3026 if No
(Finalizer
(Scop
)) then
3029 Clean_Stmts
=> No_List
,
3031 Top_Decls
=> No_List
,
3032 Defer_Abort
=> False,
3035 if Present
(Fin
) then
3036 Set_Finalizer
(Scop
, Fin
);
3043 Expand_Cleanup_Actions
(Decl
);
3051 -----------------------------------------------
3052 -- Establish_Actual_Mapping_For_Inlined_Call --
3053 -----------------------------------------------
3055 procedure Establish_Actual_Mapping_For_Inlined_Call
3059 Body_Or_Expr_To_Check
: Node_Id
)
3062 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
3063 -- Determine whether a formal parameter is used only once in
3064 -- Body_Or_Expr_To_Check.
3066 -------------------------
3067 -- Formal_Is_Used_Once --
3068 -------------------------
3070 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3071 Use_Counter
: Nat
:= 0;
3073 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3074 -- Traverse the tree and count the uses of the formal parameter.
3075 -- In this case, for optimization purposes, we do not need to
3076 -- continue the traversal once more than one use is encountered.
3082 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3084 -- The original node is an identifier
3086 if Nkind
(N
) = N_Identifier
3087 and then Present
(Entity
(N
))
3089 -- Original node's entity points to the one in the copied body
3091 and then Nkind
(Entity
(N
)) = N_Identifier
3092 and then Present
(Entity
(Entity
(N
)))
3094 -- The entity of the copied node is the formal parameter
3096 and then Entity
(Entity
(N
)) = Formal
3098 Use_Counter
:= Use_Counter
+ 1;
3100 -- If this is a second use then abandon the traversal
3102 if Use_Counter
> 1 then
3110 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3112 -- Start of processing for Formal_Is_Used_Once
3115 Count_Formal_Uses
(Body_Or_Expr_To_Check
);
3116 return Use_Counter
= 1;
3117 end Formal_Is_Used_Once
;
3124 Loc
: constant Source_Ptr
:= Sloc
(N
);
3127 Temp_Typ
: Entity_Id
;
3129 -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
3132 F
:= First_Formal
(Subp
);
3133 A
:= First_Actual
(N
);
3134 while Present
(F
) loop
3135 -- Reset Last_Assignment for any parameters of mode out or in out, to
3136 -- prevent spurious warnings about overwriting for assignments to the
3137 -- formal in the inlined code.
3139 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
3141 -- In GNATprove mode a protected component acting as an actual
3142 -- subprogram parameter will appear as inlined-for-proof. However,
3143 -- its E_Component entity is not an assignable object, so the
3144 -- assertion in Set_Last_Assignment will fail. We just omit the
3145 -- call to Set_Last_Assignment, because GNATprove flags useless
3146 -- assignments with its own flow analysis.
3148 -- In GNAT mode such a problem does not occur, because protected
3149 -- components are inlined via object renamings whose entity kind
3150 -- E_Variable is assignable.
3152 if Is_Assignable
(Entity
(A
)) then
3153 Set_Last_Assignment
(Entity
(A
), Empty
);
3156 (GNATprove_Mode
and then Is_Protected_Component
(Entity
(A
)));
3160 -- If the argument may be a controlling argument in a call within
3161 -- the inlined body, we must preserve its class-wide nature to ensure
3162 -- that dynamic dispatching will take place subsequently. If the
3163 -- formal has a constraint, then it must be preserved to retain the
3164 -- semantics of the body.
3166 if Is_Class_Wide_Type
(Etype
(F
))
3167 or else (Is_Access_Type
(Etype
(F
))
3168 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3170 Temp_Typ
:= Etype
(F
);
3172 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3173 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3174 and then Is_Constrained
(Etype
(F
))
3176 Temp_Typ
:= Etype
(F
);
3179 Temp_Typ
:= Etype
(A
);
3182 -- If the actual is a simple name or a literal, no need to create a
3183 -- temporary, object can be used directly. Skip this optimization in
3184 -- GNATprove mode, to make sure any check on a type conversion will
3187 if (Is_Entity_Name
(A
)
3189 (not Is_Scalar_Type
(Etype
(A
))
3190 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
)
3191 and then not GNATprove_Mode
)
3193 -- When the actual is an identifier and the corresponding formal is
3194 -- used only once in the original body, the formal can be substituted
3195 -- directly with the actual parameter. Skip this optimization in
3196 -- GNATprove mode, to make sure any check on a type conversion
3200 (Nkind
(A
) = N_Identifier
3201 and then Formal_Is_Used_Once
(F
)
3202 and then not GNATprove_Mode
)
3204 -- If the actual is a literal and the formal has its address taken,
3205 -- we cannot pass the literal itself as an argument, so its value
3206 -- must be captured in a temporary.
3210 N_Real_Literal | N_Integer_Literal | N_Character_Literal
3211 and then not Address_Taken
(F
))
3213 if Etype
(F
) /= Etype
(A
) then
3215 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3217 Set_Renamed_Object
(F
, A
);
3221 Temp
:= Make_Temporary
(Loc
, 'C');
3223 -- If the actual for an in/in-out parameter is a view conversion,
3224 -- make it into an unchecked conversion, given that an untagged
3225 -- type conversion is not a proper object for a renaming.
3227 -- In-out conversions that involve real conversions have already
3228 -- been transformed in Expand_Actuals.
3230 if Nkind
(A
) = N_Type_Conversion
3231 and then Ekind
(F
) /= E_In_Parameter
3233 New_A
:= Unchecked_Convert_To
(Etype
(F
), Expression
(A
));
3235 -- In GNATprove mode, keep the most precise type of the actual for
3236 -- the temporary variable, when the formal type is unconstrained.
3237 -- Otherwise, the AST may contain unexpected assignment statements
3238 -- to a temporary variable of unconstrained type renaming a local
3239 -- variable of constrained type, which is not expected by
3242 elsif Etype
(F
) /= Etype
(A
)
3243 and then (not GNATprove_Mode
or else Is_Constrained
(Etype
(F
)))
3245 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3246 Temp_Typ
:= Etype
(F
);
3249 New_A
:= Relocate_Node
(A
);
3252 Set_Sloc
(New_A
, Sloc
(N
));
3254 -- If the actual has a by-reference type, it cannot be copied,
3255 -- so its value is captured in a renaming declaration. Otherwise
3256 -- declare a local constant initialized with the actual.
3258 -- We also use a renaming declaration for expressions of an array
3259 -- type that is not bit-packed, both for efficiency reasons and to
3260 -- respect the semantics of the call: in most cases the original
3261 -- call will pass the parameter by reference, and thus the inlined
3262 -- code will have the same semantics.
3264 -- Finally, we need a renaming declaration in the case of limited
3265 -- types for which initialization cannot be by copy either.
3267 if Ekind
(F
) = E_In_Parameter
3268 and then not Is_By_Reference_Type
(Etype
(A
))
3269 and then not Is_Limited_Type
(Etype
(A
))
3271 (not Is_Array_Type
(Etype
(A
))
3272 or else not Is_Object_Reference
(A
)
3273 or else Is_Bit_Packed_Array
(Etype
(A
)))
3276 Make_Object_Declaration
(Loc
,
3277 Defining_Identifier
=> Temp
,
3278 Constant_Present
=> True,
3279 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3280 Expression
=> New_A
);
3283 -- In GNATprove mode, make an explicit copy of input
3284 -- parameters when formal and actual types differ, to make
3285 -- sure any check on the type conversion will be issued.
3286 -- The legality of the copy is ensured by calling first
3287 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3290 and then Ekind
(F
) /= E_Out_Parameter
3291 and then not Same_Type
(Etype
(F
), Etype
(A
))
3293 pragma Assert
(not Is_By_Reference_Type
(Etype
(A
)));
3294 pragma Assert
(not Is_Limited_Type
(Etype
(A
)));
3297 Make_Object_Declaration
(Loc
,
3298 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
3299 Constant_Present
=> True,
3300 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3301 Expression
=> New_Copy_Tree
(New_A
)));
3305 Make_Object_Renaming_Declaration
(Loc
,
3306 Defining_Identifier
=> Temp
,
3307 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3311 Append
(Decl
, Decls
);
3312 Set_Renamed_Object
(F
, Temp
);
3318 end Establish_Actual_Mapping_For_Inlined_Call
;
3320 -------------------------
3321 -- Expand_Inlined_Call --
3322 -------------------------
3324 procedure Expand_Inlined_Call
3327 Orig_Subp
: Entity_Id
)
3329 Decls
: constant List_Id
:= New_List
;
3330 Is_Predef
: constant Boolean :=
3331 Is_Predefined_Unit
(Get_Source_Unit
(Subp
));
3332 Loc
: constant Source_Ptr
:= Sloc
(N
);
3333 Orig_Bod
: constant Node_Id
:=
3334 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3336 Uses_Back_End
: constant Boolean :=
3337 Back_End_Inlining
and then Optimization_Level
> 0;
3338 -- The back-end expansion is used if the target supports back-end
3339 -- inlining and some level of optimixation is required; otherwise
3340 -- the inlining takes place fully as a tree expansion.
3344 Exit_Lab
: Entity_Id
:= Empty
;
3345 Lab_Decl
: Node_Id
:= Empty
;
3348 Ret_Type
: Entity_Id
;
3352 Is_Unc_Decl
: Boolean;
3353 -- If the type returned by the function is unconstrained and the call
3354 -- can be inlined, special processing is required.
3356 Return_Object
: Entity_Id
:= Empty
;
3357 -- Entity in declaration in an extended_return_statement
3359 Targ
: Node_Id
:= Empty
;
3360 -- The target of the call. If context is an assignment statement then
3361 -- this is the left-hand side of the assignment, else it is a temporary
3362 -- to which the return value is assigned prior to rewriting the call.
3364 Targ1
: Node_Id
:= Empty
;
3365 -- A separate target used when the return type is unconstrained
3367 procedure Declare_Postconditions_Result
;
3368 -- When generating C code, declare _Result, which may be used in the
3369 -- inlined _Postconditions procedure to verify the return value.
3371 procedure Make_Exit_Label
;
3372 -- Build declaration for exit label to be used in Return statements,
3373 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
3374 -- declaration). Does nothing if Exit_Lab already set.
3376 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
);
3377 -- When compiling for CCG and performing front-end inlining, replace
3378 -- loop names and references to them so that they do not conflict with
3379 -- homographs in the current subprogram.
3381 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3382 -- Replace occurrence of a formal with the corresponding actual, or the
3383 -- thunk generated for it. Replace a return statement with an assignment
3384 -- to the target of the call, with appropriate conversions if needed.
3386 function Process_Formals_In_Aspects
(N
: Node_Id
) return Traverse_Result
;
3387 -- Because aspects are linked indirectly to the rest of the tree,
3388 -- replacement of formals appearing in aspect specifications must
3389 -- be performed in a separate pass, using an instantiation of the
3390 -- previous subprogram over aspect specifications reachable from N.
3392 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3393 -- If the call being expanded is that of an internal subprogram, set the
3394 -- sloc of the generated block to that of the call itself, so that the
3395 -- expansion is skipped by the "next" command in gdb. Same processing
3396 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
3397 -- Debug_Generated_Code is true, suppress this change to simplify our
3398 -- own development. Same in GNATprove mode, to ensure that warnings and
3399 -- diagnostics point to the proper location.
3401 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
3402 -- In subtree N search for occurrences of dispatching calls that use the
3403 -- Ada 2005 Object.Operation notation and the object is a formal of the
3404 -- inlined subprogram. Reset the entity associated with Operation in all
3405 -- the found occurrences.
3407 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3408 -- If the function body is a single expression, replace call with
3409 -- expression, else insert block appropriately.
3411 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3412 -- If procedure body has no local variables, inline body without
3413 -- creating block, otherwise rewrite call with block.
3415 -----------------------------------
3416 -- Declare_Postconditions_Result --
3417 -----------------------------------
3419 procedure Declare_Postconditions_Result
is
3420 Enclosing_Subp
: constant Entity_Id
:= Scope
(Subp
);
3425 and then Is_Subprogram
(Enclosing_Subp
)
3426 and then Present
(Wrapped_Statements
(Enclosing_Subp
)));
3428 if Ekind
(Enclosing_Subp
) = E_Function
then
3429 if Nkind
(First
(Parameter_Associations
(N
))) in
3430 N_Numeric_Or_String_Literal
3432 Append_To
(Declarations
(Blk
),
3433 Make_Object_Declaration
(Loc
,
3434 Defining_Identifier
=>
3435 Make_Defining_Identifier
(Loc
, Name_uResult
),
3436 Constant_Present
=> True,
3437 Object_Definition
=>
3438 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
3440 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
3442 Append_To
(Declarations
(Blk
),
3443 Make_Object_Renaming_Declaration
(Loc
,
3444 Defining_Identifier
=>
3445 Make_Defining_Identifier
(Loc
, Name_uResult
),
3447 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
3449 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
3452 end Declare_Postconditions_Result
;
3454 ---------------------
3455 -- Make_Exit_Label --
3456 ---------------------
3458 procedure Make_Exit_Label
is
3459 Lab_Ent
: Entity_Id
;
3461 if No
(Exit_Lab
) then
3462 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
3463 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
3464 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3466 Make_Implicit_Label_Declaration
(Loc
,
3467 Defining_Identifier
=> Lab_Ent
,
3468 Label_Construct
=> Exit_Lab
);
3470 end Make_Exit_Label
;
3472 -----------------------------
3473 -- Make_Loop_Labels_Unique --
3474 -----------------------------
3476 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
) is
3477 function Process_Loop
(N
: Node_Id
) return Traverse_Result
;
3483 function Process_Loop
(N
: Node_Id
) return Traverse_Result
is
3487 if Nkind
(N
) = N_Loop_Statement
3488 and then Present
(Identifier
(N
))
3490 -- Create new external name for loop and update the
3491 -- corresponding entity.
3493 Id
:= Entity
(Identifier
(N
));
3494 Set_Chars
(Id
, New_External_Name
(Chars
(Id
), 'L', -1));
3495 Set_Chars
(Identifier
(N
), Chars
(Id
));
3497 elsif Nkind
(N
) = N_Exit_Statement
3498 and then Present
(Name
(N
))
3500 -- The exit statement must name an enclosing loop, whose name
3501 -- has already been updated.
3503 Set_Chars
(Name
(N
), Chars
(Entity
(Name
(N
))));
3509 procedure Update_Loop_Names
is new Traverse_Proc
(Process_Loop
);
3515 -- Start of processing for Make_Loop_Labels_Unique
3518 if Modify_Tree_For_C
then
3519 Stmt
:= First
(Statements
(HSS
));
3520 while Present
(Stmt
) loop
3521 Update_Loop_Names
(Stmt
);
3525 end Make_Loop_Labels_Unique
;
3527 ---------------------
3528 -- Process_Formals --
3529 ---------------------
3531 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3536 Had_Private_View
: Boolean;
3539 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3542 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
3543 A
:= Renamed_Object
(E
);
3545 -- Rewrite the occurrence of the formal into an occurrence of
3546 -- the actual. Also establish visibility on the proper view of
3547 -- the actual's subtype for the body's context (if the actual's
3548 -- subtype is private at the call point but its full view is
3549 -- visible to the body, then the inlined tree here must be
3550 -- analyzed with the full view).
3552 -- The Has_Private_View flag is cleared by rewriting, so it
3553 -- must be explicitly saved and restored, just like when
3554 -- instantiating the body to inline.
3556 if Is_Entity_Name
(A
) then
3557 Had_Private_View
:= Has_Private_View
(N
);
3558 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
3559 Set_Has_Private_View
(N
, Had_Private_View
);
3560 Check_Private_View
(N
);
3562 elsif Nkind
(A
) = N_Defining_Identifier
then
3563 Had_Private_View
:= Has_Private_View
(N
);
3564 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
3565 Set_Has_Private_View
(N
, Had_Private_View
);
3566 Check_Private_View
(N
);
3571 Rewrite
(N
, New_Copy
(A
));
3577 elsif Is_Entity_Name
(N
)
3578 and then Present
(Return_Object
)
3579 and then Chars
(N
) = Chars
(Return_Object
)
3581 -- Occurrence within an extended return statement. The return
3582 -- object is local to the body been inlined, and thus the generic
3583 -- copy is not analyzed yet, so we match by name, and replace it
3584 -- with target of call.
3586 if Nkind
(Targ
) = N_Defining_Identifier
then
3587 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
3589 Rewrite
(N
, New_Copy_Tree
(Targ
));
3594 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3595 if No
(Expression
(N
)) then
3596 Num_Ret
:= Num_Ret
+ 1;
3599 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3602 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3603 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3605 -- Function body is a single expression. No need for
3611 Num_Ret
:= Num_Ret
+ 1;
3615 -- Because of the presence of private types, the views of the
3616 -- expression and the context may be different, so place
3617 -- a type conversion to the context type to avoid spurious
3618 -- errors, e.g. when the expression is a numeric literal and
3619 -- the context is private. If the expression is an aggregate,
3620 -- use a qualified expression, because an aggregate is not a
3621 -- legal argument of a conversion. Ditto for numeric, character
3622 -- and string literals, and attributes that yield a universal
3623 -- type, because those must be resolved to a specific type.
3625 if Nkind
(Expression
(N
)) in N_Aggregate
3626 | N_Character_Literal
3629 or else Yields_Universal_Type
(Expression
(N
))
3632 Make_Qualified_Expression
(Sloc
(N
),
3633 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3634 Expression
=> Relocate_Node
(Expression
(N
)));
3636 -- Use an unchecked type conversion between access types, for
3637 -- which a type conversion would not always be valid, as no
3638 -- check may result from the conversion.
3640 elsif Is_Access_Type
(Ret_Type
) then
3642 Unchecked_Convert_To
3643 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3645 -- Otherwise use a type conversion, which may trigger a check
3649 Make_Type_Conversion
(Sloc
(N
),
3650 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3651 Expression
=> Relocate_Node
(Expression
(N
)));
3654 if Nkind
(Targ
) = N_Defining_Identifier
then
3656 Make_Assignment_Statement
(Loc
,
3657 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3658 Expression
=> Ret
));
3661 Make_Assignment_Statement
(Loc
,
3662 Name
=> New_Copy
(Targ
),
3663 Expression
=> Ret
));
3666 Set_Assignment_OK
(Name
(N
));
3668 if Present
(Exit_Lab
) then
3670 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3676 -- An extended return becomes a block whose first statement is the
3677 -- assignment of the initial expression of the return object to the
3678 -- target of the call itself.
3680 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3682 Return_Decl
: constant Entity_Id
:=
3683 First
(Return_Object_Declarations
(N
));
3687 Return_Object
:= Defining_Identifier
(Return_Decl
);
3689 if Present
(Expression
(Return_Decl
)) then
3690 if Nkind
(Targ
) = N_Defining_Identifier
then
3692 Make_Assignment_Statement
(Loc
,
3693 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3694 Expression
=> Expression
(Return_Decl
));
3697 Make_Assignment_Statement
(Loc
,
3698 Name
=> New_Copy
(Targ
),
3699 Expression
=> Expression
(Return_Decl
));
3702 Set_Assignment_OK
(Name
(Assign
));
3704 if No
(Handled_Statement_Sequence
(N
)) then
3705 Set_Handled_Statement_Sequence
(N
,
3706 Make_Handled_Sequence_Of_Statements
(Loc
,
3707 Statements
=> New_List
));
3711 Statements
(Handled_Statement_Sequence
(N
)));
3715 Make_Block_Statement
(Loc
,
3716 Handled_Statement_Sequence
=>
3717 Handled_Statement_Sequence
(N
)));
3722 -- Remove pragma Unreferenced since it may refer to formals that
3723 -- are not visible in the inlined body, and in any case we will
3724 -- not be posting warnings on the inlined body so it is unneeded.
3726 elsif Nkind
(N
) = N_Pragma
3727 and then Pragma_Name
(N
) = Name_Unreferenced
3729 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3735 end Process_Formals
;
3737 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3739 --------------------------------
3740 -- Process_Formals_In_Aspects --
3741 --------------------------------
3743 function Process_Formals_In_Aspects
3744 (N
: Node_Id
) return Traverse_Result
3747 if Nkind
(N
) = N_Aspect_Specification
then
3748 Replace_Formals
(Expression
(N
));
3751 end Process_Formals_In_Aspects
;
3753 procedure Replace_Formals_In_Aspects
is
3754 new Traverse_Proc
(Process_Formals_In_Aspects
);
3760 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3762 if not Debug_Generated_Code
then
3763 Set_Sloc
(Nod
, Sloc
(N
));
3764 Set_Comes_From_Source
(Nod
, False);
3770 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3772 ------------------------------
3773 -- Reset_Dispatching_Calls --
3774 ------------------------------
3776 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
3778 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
3784 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
3786 if Nkind
(N
) = N_Procedure_Call_Statement
3787 and then Nkind
(Name
(N
)) = N_Selected_Component
3788 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
3789 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
3790 and then Is_Dispatching_Operation
3791 (Entity
(Selector_Name
(Name
(N
))))
3793 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
3799 procedure Do_Reset_Calls
is new Traverse_Proc
(Do_Reset
);
3803 end Reset_Dispatching_Calls
;
3805 ---------------------------
3806 -- Rewrite_Function_Call --
3807 ---------------------------
3809 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3810 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3811 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3814 Make_Loop_Labels_Unique
(HSS
);
3816 -- Optimize simple case: function body is a single return statement,
3817 -- which has been expanded into an assignment.
3819 if Is_Empty_List
(Declarations
(Blk
))
3820 and then Nkind
(Fst
) = N_Assignment_Statement
3821 and then No
(Next
(Fst
))
3823 -- The function call may have been rewritten as the temporary
3824 -- that holds the result of the call, in which case remove the
3825 -- now useless declaration.
3827 if Nkind
(N
) = N_Identifier
3828 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3830 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3833 Rewrite
(N
, Expression
(Fst
));
3835 elsif Nkind
(N
) = N_Identifier
3836 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3838 -- The block assigns the result of the call to the temporary
3840 Insert_After
(Parent
(Entity
(N
)), Blk
);
3842 -- If the context is an assignment, and the left-hand side is free of
3843 -- side effects, the replacement is also safe.
3845 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3847 (Is_Entity_Name
(Name
(Parent
(N
)))
3849 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3850 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
3853 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3854 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3856 -- Replace assignment with the block
3859 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3862 -- Preserve the original assignment node to keep the complete
3863 -- assignment subtree consistent enough for Analyze_Assignment
3864 -- to proceed (specifically, the original Lhs node must still
3865 -- have an assignment statement as its parent).
3867 -- We cannot rely on Original_Node to go back from the block
3868 -- node to the assignment node, because the assignment might
3869 -- already be a rewrite substitution.
3871 Discard_Node
(Relocate_Node
(Original_Assignment
));
3872 Rewrite
(Original_Assignment
, Blk
);
3875 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3877 -- A call to a function which returns an unconstrained type
3878 -- found in the expression initializing an object-declaration is
3879 -- expanded into a procedure call which must be added after the
3880 -- object declaration.
3882 if Is_Unc_Decl
and Back_End_Inlining
then
3883 Insert_Action_After
(Parent
(N
), Blk
);
3885 Set_Expression
(Parent
(N
), Empty
);
3886 Insert_After
(Parent
(N
), Blk
);
3889 elsif Is_Unc
and then not Back_End_Inlining
then
3890 Insert_Before
(Parent
(N
), Blk
);
3892 end Rewrite_Function_Call
;
3894 ----------------------------
3895 -- Rewrite_Procedure_Call --
3896 ----------------------------
3898 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3899 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3902 Make_Loop_Labels_Unique
(HSS
);
3904 -- If there is a transient scope for N, this will be the scope of the
3905 -- actions for N, and the statements in Blk need to be within this
3906 -- scope. For example, they need to have visibility on the constant
3907 -- declarations created for the formals.
3909 -- If N needs no transient scope, and if there are no declarations in
3910 -- the inlined body, we can do a little optimization and insert the
3911 -- statements for the body directly after N, and rewrite N to a
3912 -- null statement, instead of rewriting N into a full-blown block
3915 if not Scope_Is_Transient
3916 and then Is_Empty_List
(Declarations
(Blk
))
3918 Insert_List_After
(N
, Statements
(HSS
));
3919 Rewrite
(N
, Make_Null_Statement
(Loc
));
3923 end Rewrite_Procedure_Call
;
3925 -- Start of processing for Expand_Inlined_Call
3928 -- Initializations for old/new semantics
3930 if not Uses_Back_End
then
3931 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
3932 and then not Is_Constrained
(Etype
(Subp
));
3933 Is_Unc_Decl
:= False;
3935 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
3936 and then Optimization_Level
> 0;
3937 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
3941 -- Check for an illegal attempt to inline a recursive procedure. If the
3942 -- subprogram has parameters this is detected when trying to supply a
3943 -- binding for parameters that already have one. For parameterless
3944 -- subprograms this must be done explicitly.
3946 if In_Open_Scopes
(Subp
) then
3948 ("cannot inline call to recursive subprogram?", N
, Subp
);
3949 Set_Is_Inlined
(Subp
, False);
3952 -- Skip inlining if this is not a true inlining since the attribute
3953 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3954 -- true inlining, Orig_Bod has code rather than being an entity.
3956 elsif Nkind
(Orig_Bod
) in N_Entity
then
3960 if Nkind
(Orig_Bod
) in N_Defining_Identifier
3961 | N_Defining_Operator_Symbol
3963 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3964 -- can be replaced with calls to the renamed entity directly, because
3965 -- the subprograms are subtype conformant. If the renamed subprogram
3966 -- is an inherited operation, we must redo the expansion because
3967 -- implicit conversions may be needed. Similarly, if the renamed
3968 -- entity is inlined, expand the call for further optimizations.
3970 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3972 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
3979 -- Register the call in the list of inlined calls
3981 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
3983 -- Use generic machinery to copy body of inlined subprogram, as if it
3984 -- were an instantiation, resetting source locations appropriately, so
3985 -- that nested inlined calls appear in the main unit.
3987 Save_Env
(Subp
, Empty
);
3988 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3992 if not Uses_Back_End
then
3997 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3999 Make_Block_Statement
(Loc
,
4000 Declarations
=> Declarations
(Bod
),
4001 Handled_Statement_Sequence
=>
4002 Handled_Statement_Sequence
(Bod
));
4004 if No
(Declarations
(Bod
)) then
4005 Set_Declarations
(Blk
, New_List
);
4008 -- When generating C code, declare _Result, which may be used to
4009 -- verify the return value.
4011 if Modify_Tree_For_C
4012 and then Nkind
(N
) = N_Procedure_Call_Statement
4013 and then Chars
(Name
(N
)) = Name_uWrapped_Statements
4015 Declare_Postconditions_Result
;
4018 -- For the unconstrained case, capture the name of the local
4019 -- variable that holds the result. This must be the first
4020 -- declaration in the block, because its bounds cannot depend
4021 -- on local variables. Otherwise there is no way to declare the
4022 -- result outside of the block. Needless to say, in general the
4023 -- bounds will depend on the actuals in the call.
4025 -- If the context is an assignment statement, as is the case
4026 -- for the expansion of an extended return, the left-hand side
4027 -- provides bounds even if the return type is unconstrained.
4031 First_Decl
: Node_Id
;
4034 First_Decl
:= First
(Declarations
(Blk
));
4036 -- If the body is a single extended return statement,the
4037 -- resulting block is a nested block.
4039 if No
(First_Decl
) then
4041 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
4043 if Nkind
(First_Decl
) = N_Block_Statement
then
4044 First_Decl
:= First
(Declarations
(First_Decl
));
4048 -- No front-end inlining possible
4050 if Nkind
(First_Decl
) /= N_Object_Declaration
then
4054 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
4055 Targ1
:= Defining_Identifier
(First_Decl
);
4057 Targ1
:= Name
(Parent
(N
));
4074 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
4076 Make_Block_Statement
(Loc
,
4077 Declarations
=> Declarations
(Bod
),
4078 Handled_Statement_Sequence
=>
4079 Handled_Statement_Sequence
(Bod
));
4081 -- Inline a call to a function that returns an unconstrained type.
4082 -- The semantic analyzer checked that frontend-inlined functions
4083 -- returning unconstrained types have no declarations and have
4084 -- a single extended return statement. As part of its processing
4085 -- the function was split into two subprograms: a procedure P' and
4086 -- a function F' that has a block with a call to procedure P' (see
4087 -- Split_Unconstrained_Function).
4093 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
4097 Blk_Stmt
: constant Node_Id
:=
4098 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
4099 First_Stmt
: constant Node_Id
:=
4100 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
4101 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
4105 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
4106 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
4107 and then No
(Next
(Second_Stmt
)));
4112 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
4113 Empty
, Instantiating
=> True);
4116 -- Capture the name of the local variable that holds the
4117 -- result. This must be the first declaration in the block,
4118 -- because its bounds cannot depend on local variables.
4119 -- Otherwise there is no way to declare the result outside
4120 -- of the block. Needless to say, in general the bounds will
4121 -- depend on the actuals in the call.
4123 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
4124 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
4126 -- If the context is an assignment statement, as is the case
4127 -- for the expansion of an extended return, the left-hand
4128 -- side provides bounds even if the return type is
4132 Targ1
:= Name
(Parent
(N
));
4137 if No
(Declarations
(Bod
)) then
4138 Set_Declarations
(Blk
, New_List
);
4143 -- If this is a derived function, establish the proper return type
4145 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
4146 Ret_Type
:= Etype
(Orig_Subp
);
4148 Ret_Type
:= Etype
(Subp
);
4151 -- Create temporaries for the actuals that are expressions, or that are
4152 -- scalars and require copying to preserve semantics.
4154 Establish_Actual_Mapping_For_Inlined_Call
(N
, Subp
, Decls
, Orig_Bod
);
4156 -- Establish target of function call. If context is not assignment or
4157 -- declaration, create a temporary as a target. The declaration for the
4158 -- temporary may be subsequently optimized away if the body is a single
4159 -- expression, or if the left-hand side of the assignment is simple
4160 -- enough, i.e. an entity or an explicit dereference of one.
4162 if Ekind
(Subp
) = E_Function
then
4163 if Nkind
(Parent
(N
)) = N_Assignment_Statement
4164 and then Is_Entity_Name
(Name
(Parent
(N
)))
4166 Targ
:= Name
(Parent
(N
));
4168 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
4169 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
4170 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
4172 Targ
:= Name
(Parent
(N
));
4174 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
4175 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
4176 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
4178 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
4180 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
4181 and then Is_Limited_Type
(Etype
(Subp
))
4183 Targ
:= Defining_Identifier
(Parent
(N
));
4185 -- New semantics: In an object declaration avoid an extra copy
4186 -- of the result of a call to an inlined function that returns
4187 -- an unconstrained type
4190 and then Nkind
(Parent
(N
)) = N_Object_Declaration
4193 Targ
:= Defining_Identifier
(Parent
(N
));
4196 -- Replace call with temporary and create its declaration
4198 Temp
:= Make_Temporary
(Loc
, 'C');
4199 Set_Is_Internal
(Temp
);
4201 -- For the unconstrained case, the generated temporary has the
4202 -- same constrained declaration as the result variable. It may
4203 -- eventually be possible to remove that temporary and use the
4204 -- result variable directly.
4206 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
4209 Make_Object_Declaration
(Loc
,
4210 Defining_Identifier
=> Temp
,
4211 Object_Definition
=>
4212 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
4214 Replace_Formals
(Decl
);
4218 Make_Object_Declaration
(Loc
,
4219 Defining_Identifier
=> Temp
,
4220 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
4222 Set_Etype
(Temp
, Ret_Type
);
4225 Set_No_Initialization
(Decl
);
4226 Append
(Decl
, Decls
);
4227 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4232 Insert_Actions
(N
, Decls
);
4236 -- Special management for inlining a call to a function that returns
4237 -- an unconstrained type and initializes an object declaration: we
4238 -- avoid generating undesired extra calls and goto statements.
4241 -- function Func (...) return String is
4244 -- Result : String (1 .. 4);
4246 -- Proc (Result, ...);
4251 -- Result : String := Func (...);
4253 -- Replace this object declaration by:
4255 -- Result : String (1 .. 4);
4256 -- Proc (Result, ...);
4258 Remove_Homonym
(Targ
);
4261 Make_Object_Declaration
4263 Defining_Identifier
=> Targ
,
4264 Object_Definition
=>
4265 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
4266 Replace_Formals
(Decl
);
4267 Set_No_Initialization
(Decl
);
4268 Rewrite
(Parent
(N
), Decl
);
4269 Analyze
(Parent
(N
));
4271 -- Avoid spurious warnings since we know that this declaration is
4272 -- referenced by the procedure call.
4274 Set_Never_Set_In_Source
(Targ
, False);
4276 -- Remove the local declaration of the extended return stmt from the
4279 Remove
(Parent
(Targ1
));
4281 -- Update the reference to the result (since we have rewriten the
4282 -- object declaration)
4285 Blk_Call_Stmt
: Node_Id
;
4288 -- Capture the call to the procedure
4291 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
4293 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
4295 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
4296 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
4297 New_Occurrence_Of
(Targ
, Loc
));
4300 -- Remove the return statement
4303 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4304 N_Simple_Return_Statement
);
4306 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4309 -- Traverse the tree and replace formals with actuals or their thunks.
4310 -- Attach block to tree before analysis and rewriting.
4312 Replace_Formals
(Blk
);
4313 Replace_Formals_In_Aspects
(Blk
);
4314 Set_Parent
(Blk
, N
);
4316 if GNATprove_Mode
then
4319 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
4325 -- No action needed since return statement has been already removed
4329 elsif Present
(Exit_Lab
) then
4331 -- If there's a single return statement at the end of the subprogram,
4332 -- the corresponding goto statement and the corresponding label are
4337 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4340 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4342 Append
(Lab_Decl
, (Declarations
(Blk
)));
4343 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
4347 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
4348 -- on conflicting private views that Gigi would ignore. If this is a
4349 -- predefined unit, analyze with checks off, as is done in the non-
4350 -- inlined run-time units.
4353 I_Flag
: constant Boolean := In_Inlined_Body
;
4356 In_Inlined_Body
:= True;
4360 Style
: constant Boolean := Style_Check
;
4363 Style_Check
:= False;
4365 -- Search for dispatching calls that use the Object.Operation
4366 -- notation using an Object that is a parameter of the inlined
4367 -- function. We reset the decoration of Operation to force
4368 -- the reanalysis of the inlined dispatching call because
4369 -- the actual object has been inlined.
4371 Reset_Dispatching_Calls
(Blk
);
4373 -- In GNATprove mode, always consider checks on, even for
4374 -- predefined units.
4376 if GNATprove_Mode
then
4379 Analyze
(Blk
, Suppress
=> All_Checks
);
4382 Style_Check
:= Style
;
4389 In_Inlined_Body
:= I_Flag
;
4392 if Ekind
(Subp
) = E_Procedure
then
4393 Rewrite_Procedure_Call
(N
, Blk
);
4396 Rewrite_Function_Call
(N
, Blk
);
4401 -- For the unconstrained case, the replacement of the call has been
4402 -- made prior to the complete analysis of the generated declarations.
4403 -- Propagate the proper type now.
4406 if Nkind
(N
) = N_Identifier
then
4407 Set_Etype
(N
, Etype
(Entity
(N
)));
4409 Set_Etype
(N
, Etype
(Targ1
));
4416 -- Cleanup mapping between formals and actuals for other expansions
4418 Reset_Actual_Mapping_For_Inlined_Call
(Subp
);
4419 end Expand_Inlined_Call
;
4421 --------------------------
4422 -- Get_Code_Unit_Entity --
4423 --------------------------
4425 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
4426 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
4429 if Ekind
(Unit
) = E_Package_Body
then
4430 Unit
:= Spec_Entity
(Unit
);
4434 end Get_Code_Unit_Entity
;
4436 ------------------------------
4437 -- Has_Excluded_Declaration --
4438 ------------------------------
4440 function Has_Excluded_Declaration
4442 Decls
: List_Id
) return Boolean
4444 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
4445 -- Nested subprograms make a given body ineligible for inlining, but
4446 -- we make an exception for instantiations of unchecked conversion.
4447 -- The body has not been analyzed yet, so check the name, and verify
4448 -- that the visible entity with that name is the predefined unit.
4450 -----------------------------
4451 -- Is_Unchecked_Conversion --
4452 -----------------------------
4454 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
4455 Id
: constant Node_Id
:= Name
(D
);
4459 if Nkind
(Id
) = N_Identifier
4460 and then Chars
(Id
) = Name_Unchecked_Conversion
4462 Conv
:= Current_Entity
(Id
);
4464 elsif Nkind
(Id
) in N_Selected_Component | N_Expanded_Name
4465 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
4467 Conv
:= Current_Entity
(Selector_Name
(Id
));
4472 return Present
(Conv
)
4473 and then Is_Predefined_Unit
(Get_Source_Unit
(Conv
))
4474 and then Is_Intrinsic_Subprogram
(Conv
);
4475 end Is_Unchecked_Conversion
;
4481 -- Start of processing for Has_Excluded_Declaration
4484 -- No action needed if the check is not needed
4486 if not Check_Inlining_Restrictions
then
4490 Decl
:= First
(Decls
);
4491 while Present
(Decl
) loop
4493 -- First declarations universally excluded
4495 if Nkind
(Decl
) = N_Package_Declaration
then
4497 ("cannot inline & (nested package declaration)?", Decl
, Subp
);
4500 elsif Nkind
(Decl
) = N_Package_Instantiation
then
4502 ("cannot inline & (nested package instantiation)?", Decl
, Subp
);
4506 -- Then declarations excluded only for front-end inlining
4508 if Back_End_Inlining
then
4511 elsif Nkind
(Decl
) = N_Task_Type_Declaration
4512 or else Nkind
(Decl
) = N_Single_Task_Declaration
4515 ("cannot inline & (nested task type declaration)?", Decl
, Subp
);
4518 elsif Nkind
(Decl
) in N_Protected_Type_Declaration
4519 | N_Single_Protected_Declaration
4522 ("cannot inline & (nested protected type declaration)?",
4526 elsif Nkind
(Decl
) = N_Subprogram_Body
then
4528 ("cannot inline & (nested subprogram)?", Decl
, Subp
);
4531 elsif Nkind
(Decl
) = N_Function_Instantiation
4532 and then not Is_Unchecked_Conversion
(Decl
)
4535 ("cannot inline & (nested function instantiation)?", Decl
, Subp
);
4538 elsif Nkind
(Decl
) = N_Procedure_Instantiation
then
4540 ("cannot inline & (nested procedure instantiation)?",
4544 -- Subtype declarations with predicates will generate predicate
4545 -- functions, i.e. nested subprogram bodies, so inlining is not
4548 elsif Nkind
(Decl
) = N_Subtype_Declaration
then
4554 A
:= First
(Aspect_Specifications
(Decl
));
4555 while Present
(A
) loop
4556 A_Id
:= Get_Aspect_Id
(Chars
(Identifier
(A
)));
4558 if A_Id
= Aspect_Predicate
4559 or else A_Id
= Aspect_Static_Predicate
4560 or else A_Id
= Aspect_Dynamic_Predicate
4563 ("cannot inline & (subtype declaration with "
4564 & "predicate)?", Decl
, Subp
);
4577 end Has_Excluded_Declaration
;
4579 ----------------------------
4580 -- Has_Excluded_Statement --
4581 ----------------------------
4583 function Has_Excluded_Statement
4585 Stats
: List_Id
) return Boolean
4591 -- No action needed if the check is not needed
4593 if not Check_Inlining_Restrictions
then
4598 while Present
(S
) loop
4599 if Nkind
(S
) in N_Abort_Statement
4600 | N_Asynchronous_Select
4601 | N_Conditional_Entry_Call
4602 | N_Delay_Relative_Statement
4603 | N_Delay_Until_Statement
4604 | N_Selective_Accept
4605 | N_Timed_Entry_Call
4608 ("cannot inline & (non-allowed statement)?", S
, Subp
);
4611 elsif Nkind
(S
) = N_Block_Statement
then
4612 if Has_Excluded_Declaration
(Subp
, Declarations
(S
)) then
4615 elsif Present
(Handled_Statement_Sequence
(S
)) then
4616 if not Back_End_Inlining
4619 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
4622 ("cannot inline& (exception handler)?",
4623 First
(Exception_Handlers
4624 (Handled_Statement_Sequence
(S
))),
4628 elsif Has_Excluded_Statement
4629 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4635 elsif Nkind
(S
) = N_Case_Statement
then
4636 E
:= First
(Alternatives
(S
));
4637 while Present
(E
) loop
4638 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
4645 elsif Nkind
(S
) = N_If_Statement
then
4646 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
4650 if Present
(Elsif_Parts
(S
)) then
4651 E
:= First
(Elsif_Parts
(S
));
4652 while Present
(E
) loop
4653 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
4661 if Present
(Else_Statements
(S
))
4662 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
4667 elsif Nkind
(S
) = N_Loop_Statement
4668 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
4672 elsif Nkind
(S
) = N_Extended_Return_Statement
then
4673 if Present
(Handled_Statement_Sequence
(S
))
4675 Has_Excluded_Statement
4676 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4680 elsif not Back_End_Inlining
4681 and then Present
(Handled_Statement_Sequence
(S
))
4683 Present
(Exception_Handlers
4684 (Handled_Statement_Sequence
(S
)))
4687 ("cannot inline& (exception handler)?",
4688 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
4698 end Has_Excluded_Statement
;
4700 --------------------------
4701 -- Has_Initialized_Type --
4702 --------------------------
4704 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
4705 E_Body
: constant Node_Id
:= Subprogram_Body
(E
);
4709 if No
(E_Body
) then -- imported subprogram
4713 Decl
:= First
(Declarations
(E_Body
));
4714 while Present
(Decl
) loop
4715 if Nkind
(Decl
) = N_Full_Type_Declaration
4716 and then Comes_From_Source
(Decl
)
4717 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
4727 end Has_Initialized_Type
;
4729 -----------------------
4730 -- Has_Single_Return --
4731 -----------------------
4733 function Has_Single_Return
(N
: Node_Id
) return Boolean is
4734 Return_Statement
: Node_Id
:= Empty
;
4736 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
4742 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
4744 if Nkind
(N
) = N_Simple_Return_Statement
then
4745 if Present
(Expression
(N
))
4746 and then Is_Entity_Name
(Expression
(N
))
4748 pragma Assert
(Present
(Entity
(Expression
(N
))));
4750 if No
(Return_Statement
) then
4751 Return_Statement
:= N
;
4756 (Present
(Entity
(Expression
(Return_Statement
))));
4758 if Entity
(Expression
(N
)) =
4759 Entity
(Expression
(Return_Statement
))
4767 -- A return statement within an extended return is a noop after
4770 elsif No
(Expression
(N
))
4771 and then Nkind
(Parent
(Parent
(N
))) =
4772 N_Extended_Return_Statement
4777 -- Expression has wrong form
4782 -- We can only inline a build-in-place function if it has a single
4785 elsif Nkind
(N
) = N_Extended_Return_Statement
then
4786 if No
(Return_Statement
) then
4787 Return_Statement
:= N
;
4799 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
4801 -- Start of processing for Has_Single_Return
4804 if Check_All_Returns
(N
) /= OK
then
4807 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
4812 Present
(First
(Declarations
(N
)))
4813 and then Nkind
(First
(Declarations
(N
))) = N_Object_Declaration
4814 and then Entity
(Expression
(Return_Statement
)) =
4815 Defining_Identifier
(First
(Declarations
(N
)));
4817 end Has_Single_Return
;
4819 -----------------------------
4820 -- In_Main_Unit_Or_Subunit --
4821 -----------------------------
4823 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
4824 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
4827 -- Check whether the subprogram or package to inline is within the main
4828 -- unit or its spec or within a subunit. In either case there are no
4829 -- additional bodies to process. If the subprogram appears in a parent
4830 -- of the current unit, the check on whether inlining is possible is
4831 -- done in Analyze_Inlined_Bodies.
4833 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
4834 Comp
:= Library_Unit
(Comp
);
4837 return Comp
= Cunit
(Main_Unit
)
4838 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
4839 end In_Main_Unit_Or_Subunit
;
4845 procedure Initialize
is
4847 Pending_Instantiations
.Init
;
4848 Called_Pending_Instantiations
.Init
;
4849 Inlined_Bodies
.Init
;
4853 for J
in Hash_Headers
'Range loop
4854 Hash_Headers
(J
) := No_Subp
;
4857 Inlined_Calls
:= No_Elist
;
4858 Backend_Calls
:= No_Elist
;
4859 Backend_Instances
:= No_Elist
;
4860 Backend_Inlined_Subps
:= No_Elist
;
4861 Backend_Not_Inlined_Subps
:= No_Elist
;
4864 ---------------------------------
4865 -- Inline_Static_Function_Call --
4866 ---------------------------------
4868 procedure Inline_Static_Function_Call
(N
: Node_Id
; Subp
: Entity_Id
) is
4870 function Replace_Formal
(N
: Node_Id
) return Traverse_Result
;
4871 -- Replace each occurrence of a formal with the
4872 -- corresponding actual, using the mapping created
4873 -- by Establish_Actual_Mapping_For_Inlined_Call.
4875 function Reset_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
4876 -- Reset the Sloc of a node to that of the call itself, so that errors
4877 -- will be flagged on the call to the static expression function itself
4878 -- rather than on the expression of the function's declaration.
4880 --------------------
4881 -- Replace_Formal --
4882 --------------------
4884 function Replace_Formal
(N
: Node_Id
) return Traverse_Result
is
4889 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
4892 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
4893 A
:= Renamed_Object
(E
);
4895 if Nkind
(A
) = N_Defining_Identifier
then
4896 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
4901 Rewrite
(N
, New_Copy
(A
));
4912 procedure Replace_Formals
is new Traverse_Proc
(Replace_Formal
);
4918 function Reset_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
4920 Set_Sloc
(Nod
, Sloc
(N
));
4921 Set_Comes_From_Source
(Nod
, False);
4926 procedure Reset_Slocs
is new Traverse_Proc
(Reset_Sloc
);
4928 -- Start of processing for Inline_Static_Function_Call
4931 pragma Assert
(Is_Static_Function_Call
(N
));
4934 Decls
: constant List_Id
:= New_List
;
4935 Func_Expr
: constant Node_Id
:=
4936 Expression_Of_Expression_Function
(Subp
);
4937 Expr_Copy
: constant Node_Id
:= New_Copy_Tree
(Func_Expr
);
4940 -- Create a mapping from formals to actuals, also creating temps in
4941 -- Decls, when needed, to hold the actuals.
4943 Establish_Actual_Mapping_For_Inlined_Call
(N
, Subp
, Decls
, Func_Expr
);
4945 -- Ensure that the copy has the same parent as the call (this seems
4946 -- to matter when GNATprove_Mode is set and there are nested static
4947 -- calls; prevents blowups in Insert_Actions, though it's not clear
4948 -- exactly why this is needed???).
4950 Set_Parent
(Expr_Copy
, Parent
(N
));
4952 Insert_Actions
(N
, Decls
);
4954 -- Now substitute actuals for their corresponding formal references
4955 -- within the expression.
4957 Replace_Formals
(Expr_Copy
);
4959 Reset_Slocs
(Expr_Copy
);
4961 -- Apply a qualified expression with the function's result subtype,
4962 -- to ensure that we check the expression against any constraint
4963 -- or predicate, which will cause the call to be illegal if the
4964 -- folded expression doesn't satisfy them. (The predicate case
4965 -- might not get checked if the subtype hasn't been frozen yet,
4966 -- which can happen if this static expression happens to be what
4967 -- causes the freezing, because Has_Static_Predicate doesn't get
4968 -- set on the subtype until it's frozen and Build_Predicates is
4969 -- called. It's not clear how to address this case. ???)
4972 Make_Qualified_Expression
(Sloc
(Expr_Copy
),
4974 New_Occurrence_Of
(Etype
(N
), Sloc
(Expr_Copy
)),
4976 Relocate_Node
(Expr_Copy
)));
4978 Set_Etype
(Expr_Copy
, Etype
(N
));
4980 Analyze_And_Resolve
(Expr_Copy
, Etype
(N
));
4982 -- Finally rewrite the function call as the folded static result
4984 Rewrite
(N
, Expr_Copy
);
4986 -- Cleanup mapping between formals and actuals for other expansions
4988 Reset_Actual_Mapping_For_Inlined_Call
(Subp
);
4990 end Inline_Static_Function_Call
;
4992 ------------------------
4993 -- Instantiate_Bodies --
4994 ------------------------
4996 -- Generic bodies contain all the non-local references, so an
4997 -- instantiation does not need any more context than Standard
4998 -- itself, even if the instantiation appears in an inner scope.
4999 -- Generic associations have verified that the contract model is
5000 -- satisfied, so that any error that may occur in the analysis of
5001 -- the body is an internal error.
5003 procedure Instantiate_Bodies
is
5005 procedure Instantiate_Body
(Info
: Pending_Body_Info
);
5006 -- Instantiate a pending body
5008 ------------------------
5009 -- Instantiate_Body --
5010 ------------------------
5012 procedure Instantiate_Body
(Info
: Pending_Body_Info
) is
5016 -- If the instantiation node is absent, it has been removed as part
5017 -- of unreachable code.
5019 if No
(Info
.Inst_Node
) then
5022 -- If the instantiation node is a package body, this means that the
5023 -- instance is a compilation unit and the instantiation has already
5024 -- been performed by Build_Instance_Compilation_Unit_Nodes.
5026 elsif Nkind
(Info
.Inst_Node
) = N_Package_Body
then
5029 -- For other package instances, instantiate the body and register the
5030 -- finalization scope, if any, for subsequent generation of cleanups.
5032 elsif Nkind
(Info
.Inst_Node
) = N_Package_Instantiation
then
5034 -- If the enclosing finalization scope is a package body, set the
5035 -- In_Package_Body flag on its spec. This is required, in the case
5036 -- where the body contains other package instantiations that have
5037 -- a body, for Analyze_Package_Instantiation to compute a correct
5038 -- finalization scope.
5040 if Present
(Info
.Fin_Scop
)
5041 and then Ekind
(Info
.Fin_Scop
) = E_Package_Body
5043 Set_In_Package_Body
(Spec_Entity
(Info
.Fin_Scop
), True);
5046 Instantiate_Package_Body
(Info
);
5048 if Present
(Info
.Fin_Scop
) then
5049 Scop
:= Info
.Fin_Scop
;
5051 -- If the enclosing finalization scope is dynamic, the instance
5052 -- may have been relocated, for example if it was declared in a
5053 -- protected entry, protected subprogram, or task body.
5055 if Is_Dynamic_Scope
(Scop
) then
5057 Enclosing_Dynamic_Scope
(Defining_Entity
(Info
.Act_Decl
));
5060 Add_Scope_To_Clean
(Scop
);
5062 -- Reset the In_Package_Body flag if it was set above
5064 if Ekind
(Info
.Fin_Scop
) = E_Package_Body
then
5065 Set_In_Package_Body
(Spec_Entity
(Info
.Fin_Scop
), False);
5069 -- For subprogram instances, always instantiate the body
5072 Instantiate_Subprogram_Body
(Info
);
5074 end Instantiate_Body
;
5077 Info
: Pending_Body_Info
;
5079 -- Start of processing for Instantiate_Bodies
5082 if Serious_Errors_Detected
= 0 then
5083 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
5084 Push_Scope
(Standard_Standard
);
5085 To_Clean
:= New_Elmt_List
;
5087 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
5091 -- A body instantiation may generate additional instantiations, so
5092 -- the following loop must scan to the end of a possibly expanding
5093 -- set (that's why we cannot simply use a FOR loop here). We must
5094 -- also capture the element lest the set be entirely reallocated.
5097 if Back_End_Inlining
then
5098 while J
<= Called_Pending_Instantiations
.Last
5099 and then Serious_Errors_Detected
= 0
5101 K
:= Called_Pending_Instantiations
.Table
(J
);
5102 Info
:= Pending_Instantiations
.Table
(K
);
5103 Instantiate_Body
(Info
);
5109 while J
<= Pending_Instantiations
.Last
5110 and then Serious_Errors_Detected
= 0
5112 Info
:= Pending_Instantiations
.Table
(J
);
5113 Instantiate_Body
(Info
);
5119 -- Reset the table of instantiations. Additional instantiations
5120 -- may be added through inlining, when additional bodies are
5123 if Back_End_Inlining
then
5124 Called_Pending_Instantiations
.Init
;
5126 Pending_Instantiations
.Init
;
5129 -- We can now complete the cleanup actions of scopes that contain
5130 -- pending instantiations (skipped for generic units, since we
5131 -- never need any cleanups in generic units).
5134 and then not Is_Generic_Unit
(Main_Unit_Entity
)
5137 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
5143 end Instantiate_Bodies
;
5149 function Is_Nested
(E
: Entity_Id
) return Boolean is
5154 while Scop
/= Standard_Standard
loop
5155 if Is_Subprogram
(Scop
) then
5158 elsif Ekind
(Scop
) = E_Task_Type
5159 or else Ekind
(Scop
) = E_Entry
5160 or else Ekind
(Scop
) = E_Entry_Family
5165 Scop
:= Scope
(Scop
);
5171 ------------------------
5172 -- List_Inlining_Info --
5173 ------------------------
5175 procedure List_Inlining_Info
is
5181 if not Debug_Flag_Dot_J
then
5185 -- Generate listing of calls inlined by the frontend
5187 if Present
(Inlined_Calls
) then
5189 Elmt
:= First_Elmt
(Inlined_Calls
);
5190 while Present
(Elmt
) loop
5193 if not In_Internal_Unit
(Nod
) then
5197 Write_Str
("List of calls inlined by the frontend");
5204 Write_Location
(Sloc
(Nod
));
5213 -- Generate listing of calls passed to the backend
5215 if Present
(Backend_Calls
) then
5218 Elmt
:= First_Elmt
(Backend_Calls
);
5219 while Present
(Elmt
) loop
5222 if not In_Internal_Unit
(Nod
) then
5226 Write_Str
("List of inlined calls passed to the backend");
5233 Write_Location
(Sloc
(Nod
));
5241 -- Generate listing of instances inlined for the backend
5243 if Present
(Backend_Instances
) then
5246 Elmt
:= First_Elmt
(Backend_Instances
);
5247 while Present
(Elmt
) loop
5250 if not In_Internal_Unit
(Nod
) then
5254 Write_Str
("List of instances inlined for the backend");
5261 Write_Location
(Sloc
(Nod
));
5269 -- Generate listing of subprograms passed to the backend
5271 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
5274 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
5275 while Present
(Elmt
) loop
5278 if not In_Internal_Unit
(Nod
) then
5283 ("List of inlined subprograms passed to the backend");
5290 Write_Name
(Chars
(Nod
));
5292 Write_Location
(Sloc
(Nod
));
5301 -- Generate listing of subprograms that cannot be inlined by the backend
5303 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
5306 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
5307 while Present
(Elmt
) loop
5310 if not In_Internal_Unit
(Nod
) then
5315 ("List of subprograms that cannot be inlined by backend");
5322 Write_Name
(Chars
(Nod
));
5324 Write_Location
(Sloc
(Nod
));
5332 end List_Inlining_Info
;
5340 Pending_Instantiations
.Release
;
5341 Pending_Instantiations
.Locked
:= True;
5342 Called_Pending_Instantiations
.Release
;
5343 Called_Pending_Instantiations
.Locked
:= True;
5344 Inlined_Bodies
.Release
;
5345 Inlined_Bodies
.Locked
:= True;
5347 Successors
.Locked
:= True;
5349 Inlined
.Locked
:= True;
5352 --------------------------------
5353 -- Remove_Aspects_And_Pragmas --
5354 --------------------------------
5356 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
5357 procedure Remove_Items
(List
: List_Id
);
5358 -- Remove all useless aspects/pragmas from a particular list
5364 procedure Remove_Items
(List
: List_Id
) is
5367 Next_Item
: Node_Id
;
5370 -- Traverse the list looking for an aspect specification or a pragma
5372 Item
:= First
(List
);
5373 while Present
(Item
) loop
5374 Next_Item
:= Next
(Item
);
5376 if Nkind
(Item
) = N_Aspect_Specification
then
5377 Item_Id
:= Identifier
(Item
);
5378 elsif Nkind
(Item
) = N_Pragma
then
5379 Item_Id
:= Pragma_Identifier
(Item
);
5384 if Present
(Item_Id
)
5385 and then Chars
(Item_Id
) in Name_Always_Terminates
5386 | Name_Contract_Cases
5389 | Name_Exceptional_Cases
5390 | Name_Postcondition
5392 | Name_Refined_Global
5393 | Name_Refined_Depends
5395 | Name_Subprogram_Variant
5408 -- Start of processing for Remove_Aspects_And_Pragmas
5411 Remove_Items
(Aspect_Specifications
(Body_Decl
));
5412 Remove_Items
(Declarations
(Body_Decl
));
5414 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
5415 -- in the body of the subprogram.
5417 Remove_Items
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
5418 end Remove_Aspects_And_Pragmas
;
5420 --------------------------
5421 -- Remove_Dead_Instance --
5422 --------------------------
5424 procedure Remove_Dead_Instance
(N
: Node_Id
) is
5426 for J
in 0 .. Pending_Instantiations
.Last
loop
5427 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
5428 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
5432 end Remove_Dead_Instance
;
5434 -------------------------------------------
5435 -- Reset_Actual_Mapping_For_Inlined_Call --
5436 -------------------------------------------
5438 procedure Reset_Actual_Mapping_For_Inlined_Call
(Subp
: Entity_Id
) is
5439 F
: Entity_Id
:= First_Formal
(Subp
);
5442 while Present
(F
) loop
5443 Set_Renamed_Object
(F
, Empty
);
5446 end Reset_Actual_Mapping_For_Inlined_Call
;