1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, 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 Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Expander
; use Expander
;
34 with Exp_Ch6
; use Exp_Ch6
;
35 with Exp_Ch7
; use Exp_Ch7
;
36 with Exp_Tss
; use Exp_Tss
;
37 with Exp_Util
; use Exp_Util
;
38 with Fname
; use Fname
;
39 with Fname
.UF
; use Fname
.UF
;
41 with Namet
; use Namet
;
42 with Nmake
; use Nmake
;
43 with Nlists
; use Nlists
;
44 with Output
; use Output
;
45 with Sem_Aux
; use Sem_Aux
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Ch10
; use Sem_Ch10
;
48 with Sem_Ch12
; use Sem_Ch12
;
49 with Sem_Prag
; use Sem_Prag
;
50 with Sem_Res
; use Sem_Res
;
51 with Sem_Util
; use Sem_Util
;
52 with Sinfo
; use Sinfo
;
53 with Sinput
; use Sinput
;
54 with Snames
; use Snames
;
55 with Stand
; use Stand
;
57 with Tbuild
; use Tbuild
;
58 with Uintp
; use Uintp
;
59 with Uname
; use Uname
;
63 package body Inline
is
65 Check_Inlining_Restrictions
: constant Boolean := True;
66 -- In the following cases the frontend rejects inlining because they
67 -- are not handled well by the backend. This variable facilitates
68 -- disabling these restrictions to evaluate future versions of the
69 -- GCC backend in which some of the restrictions may be supported.
71 -- - subprograms that have:
72 -- - nested subprograms
74 -- - package declarations
75 -- - task or protected object declarations
76 -- - some of the following statements:
78 -- - asynchronous-select
79 -- - conditional-entry-call
85 Inlined_Calls
: Elist_Id
;
86 -- List of frontend inlined calls
88 Backend_Calls
: Elist_Id
;
89 -- List of inline calls passed to the backend
91 Backend_Instances
: Elist_Id
;
92 -- List of instances inlined for the backend
94 Backend_Inlined_Subps
: Elist_Id
;
95 -- List of subprograms inlined by the backend
97 Backend_Not_Inlined_Subps
: Elist_Id
;
98 -- List of subprograms that cannot be inlined by the backend
100 -----------------------------
101 -- Pending_Instantiations --
102 -----------------------------
104 -- We make entries in this table for the pending instantiations of generic
105 -- bodies that are created during semantic analysis. After the analysis is
106 -- complete, calling Instantiate_Bodies performs the actual instantiations.
108 package Pending_Instantiations
is new Table
.Table
(
109 Table_Component_Type
=> Pending_Body_Info
,
110 Table_Index_Type
=> Int
,
111 Table_Low_Bound
=> 0,
112 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
113 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
114 Table_Name
=> "Pending_Instantiations");
116 -------------------------------------
117 -- Called_Pending_Instantiations --
118 -------------------------------------
120 -- With back-end inlining, the pending instantiations that are not in the
121 -- main unit or subunit are performed only after a call to the subprogram
122 -- instance, or to a subprogram within the package instance, is inlined.
123 -- Since such a call can be within a subsequent pending instantiation,
124 -- we make entries in this table that stores the index of these "called"
125 -- pending instantiations and perform them when the table is populated.
127 package Called_Pending_Instantiations
is new Table
.Table
(
128 Table_Component_Type
=> Int
,
129 Table_Index_Type
=> Int
,
130 Table_Low_Bound
=> 0,
131 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
132 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
133 Table_Name
=> "Called_Pending_Instantiations");
135 ---------------------------------
136 -- To_Pending_Instantiations --
137 ---------------------------------
139 -- With back-end inlining, we also need to have a map from the pending
140 -- instantiations to their index in the Pending_Instantiations table.
142 Node_Table_Size
: constant := 257;
143 -- Number of headers in hash table
145 subtype Node_Header_Num
is Integer range 0 .. Node_Table_Size
- 1;
146 -- Range of headers in hash table
148 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
;
149 -- Simple hash function for Node_Ids
151 package To_Pending_Instantiations
is new GNAT
.Htable
.Simple_HTable
152 (Header_Num
=> Node_Header_Num
,
163 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
is
165 return Node_Header_Num
(Id
mod Node_Table_Size
);
172 -- Inlined functions are actually placed in line by the backend if the
173 -- corresponding bodies are available (i.e. compiled). Whenever we find
174 -- a call to an inlined subprogram, we add the name of the enclosing
175 -- compilation unit to a worklist. After all compilation, and after
176 -- expansion of generic bodies, we traverse the list of pending bodies
177 -- and compile them as well.
179 package Inlined_Bodies
is new Table
.Table
(
180 Table_Component_Type
=> Entity_Id
,
181 Table_Index_Type
=> Int
,
182 Table_Low_Bound
=> 0,
183 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
184 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
185 Table_Name
=> "Inlined_Bodies");
187 -----------------------
188 -- Inline Processing --
189 -----------------------
191 -- For each call to an inlined subprogram, we make entries in a table
192 -- that stores caller and callee, and indicates the call direction from
193 -- one to the other. We also record the compilation unit that contains
194 -- the callee. After analyzing the bodies of all such compilation units,
195 -- we compute the transitive closure of inlined subprograms called from
196 -- the main compilation unit and make it available to the code generator
197 -- in no particular order, thus allowing cycles in the call graph.
199 Last_Inlined
: Entity_Id
:= Empty
;
201 -- For each entry in the table we keep a list of successors in topological
202 -- order, i.e. callers of the current subprogram.
204 type Subp_Index
is new Nat
;
205 No_Subp
: constant Subp_Index
:= 0;
207 -- The subprogram entities are hashed into the Inlined table
209 Num_Hash_Headers
: constant := 512;
211 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
214 type Succ_Index
is new Nat
;
215 No_Succ
: constant Succ_Index
:= 0;
217 type Succ_Info
is record
222 -- The following table stores list elements for the successor lists. These
223 -- lists cannot be chained directly through entries in the Inlined table,
224 -- because a given subprogram can appear in several such lists.
226 package Successors
is new Table
.Table
(
227 Table_Component_Type
=> Succ_Info
,
228 Table_Index_Type
=> Succ_Index
,
229 Table_Low_Bound
=> 1,
230 Table_Initial
=> Alloc
.Successors_Initial
,
231 Table_Increment
=> Alloc
.Successors_Increment
,
232 Table_Name
=> "Successors");
234 type Subp_Info
is record
235 Name
: Entity_Id
:= Empty
;
236 Next
: Subp_Index
:= No_Subp
;
237 First_Succ
: Succ_Index
:= No_Succ
;
238 Main_Call
: Boolean := False;
239 Processed
: Boolean := False;
242 package Inlined
is new Table
.Table
(
243 Table_Component_Type
=> Subp_Info
,
244 Table_Index_Type
=> Subp_Index
,
245 Table_Low_Bound
=> 1,
246 Table_Initial
=> Alloc
.Inlined_Initial
,
247 Table_Increment
=> Alloc
.Inlined_Increment
,
248 Table_Name
=> "Inlined");
250 -----------------------
251 -- Local Subprograms --
252 -----------------------
254 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
255 -- Make two entries in Inlined table, for an inlined subprogram being
256 -- called, and for the inlined subprogram that contains the call. If
257 -- the call is in the main compilation unit, Caller is Empty.
259 procedure Add_Inlined_Instance
(E
: Entity_Id
);
260 -- Add instance E to the list of inlined instances for the unit
262 procedure Add_Inlined_Subprogram
(E
: Entity_Id
);
263 -- Add subprogram E to the list of inlined subprograms for the unit
265 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
266 -- Make entry in Inlined table for subprogram E, or return table index
267 -- that already holds E.
269 procedure Establish_Actual_Mapping_For_Inlined_Call
273 Body_Or_Expr_To_Check
: Node_Id
);
274 -- Establish a mapping from formals to actuals in the call N for the target
275 -- subprogram Subp, and create temporaries or renamings when needed for the
276 -- actuals that are expressions (except for actuals given by simple entity
277 -- names or literals) or that are scalars that require copying to preserve
278 -- semantics. Any temporary objects that are created are inserted in Decls.
279 -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
280 -- of an expression function), which may be traversed to count formal uses.
282 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
;
283 pragma Inline
(Get_Code_Unit_Entity
);
284 -- Return the entity node for the unit containing E. Always return the spec
287 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
288 -- If a candidate for inlining contains type declarations for types with
289 -- nontrivial initialization procedures, they are not worth inlining.
291 function Has_Single_Return
(N
: Node_Id
) return Boolean;
292 -- In general we cannot inline functions that return unconstrained type.
293 -- However, we can handle such functions if all return statements return
294 -- a local variable that is the first declaration in the body of the
295 -- function. In that case the call can be replaced by that local
296 -- variable as is done for other inlined calls.
298 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean;
299 -- Return True if E is in the main unit or its spec or in a subunit
301 function Is_Nested
(E
: Entity_Id
) return Boolean;
302 -- If the function is nested inside some other function, it will always
303 -- be compiled if that function is, so don't add it to the inline list.
304 -- We cannot compile a nested function outside the scope of the containing
305 -- function anyway. This is also the case if the function is defined in a
306 -- task body or within an entry (for example, an initialization procedure).
308 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
);
309 -- Remove all aspects and/or pragmas that have no meaning in inlined body
310 -- Body_Decl. The analysis of these items is performed on the non-inlined
311 -- body. The items currently removed are:
320 -- Subprogram_Variant
325 procedure Reset_Actual_Mapping_For_Inlined_Call
(Subp
: Entity_Id
);
326 -- Reset the Renamed_Object flags on the formals of Subp, which can be set
327 -- by a call to Establish_Actual_Mapping_For_Inlined_Call.
329 ------------------------------
330 -- Deferred Cleanup Actions --
331 ------------------------------
333 -- The cleanup actions for scopes that contain instantiations is delayed
334 -- until after expansion of those instantiations, because they may contain
335 -- finalizable objects or tasks that affect the cleanup code. A scope
336 -- that contains instantiations only needs to be finalized once, even
337 -- if it contains more than one instance. We keep a list of scopes
338 -- that must still be finalized, and call cleanup_actions after all
339 -- the instantiations have been completed.
343 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
344 -- Build set of scopes on which cleanup actions must be performed
346 procedure Cleanup_Scopes
;
347 -- Complete cleanup actions on scopes that need it
353 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
354 P1
: constant Subp_Index
:= Add_Subp
(Called
);
359 if Present
(Caller
) then
360 P2
:= Add_Subp
(Caller
);
362 -- Add P1 to the list of successors of P2, if not already there.
363 -- Note that P2 may contain more than one call to P1, and only
364 -- one needs to be recorded.
366 J
:= Inlined
.Table
(P2
).First_Succ
;
367 while J
/= No_Succ
loop
368 if Successors
.Table
(J
).Subp
= P1
then
372 J
:= Successors
.Table
(J
).Next
;
375 -- On exit, make a successor entry for P1
377 Successors
.Increment_Last
;
378 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
379 Successors
.Table
(Successors
.Last
).Next
:=
380 Inlined
.Table
(P2
).First_Succ
;
381 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
383 Inlined
.Table
(P1
).Main_Call
:= True;
387 ----------------------
388 -- Add_Inlined_Body --
389 ----------------------
391 procedure Add_Inlined_Body
(E
: Entity_Id
; N
: Node_Id
) is
393 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
394 -- Level of inlining for the call: Dont_Inline means no inlining,
395 -- Inline_Call means that only the call is considered for inlining,
396 -- Inline_Package means that the call is considered for inlining and
397 -- its package compiled and scanned for more inlining opportunities.
399 function Is_Non_Loading_Expression_Function
400 (Id
: Entity_Id
) return Boolean;
401 -- Determine whether arbitrary entity Id denotes a subprogram which is
404 -- * An expression function
406 -- * A function completed by an expression function where both the
407 -- spec and body are in the same context.
409 function Must_Inline
return Inline_Level_Type
;
410 -- Inlining is only done if the call statement N is in the main unit,
411 -- or within the body of another inlined subprogram.
413 ----------------------------------------
414 -- Is_Non_Loading_Expression_Function --
415 ----------------------------------------
417 function Is_Non_Loading_Expression_Function
418 (Id
: Entity_Id
) return Boolean
425 -- A stand-alone expression function is transformed into a spec-body
426 -- pair in-place. Since both the spec and body are in the same list,
427 -- the inlining of such an expression function does not need to load
430 if Is_Expression_Function
(Id
) then
433 -- A function may be completed by an expression function
435 elsif Ekind
(Id
) = E_Function
then
436 Spec_Decl
:= Unit_Declaration_Node
(Id
);
438 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
then
439 Body_Id
:= Corresponding_Body
(Spec_Decl
);
441 if Present
(Body_Id
) then
442 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
444 -- The inlining of a completing expression function does
445 -- not need to load anything extra when both the spec and
446 -- body are in the same context.
449 Was_Expression_Function
(Body_Decl
)
450 and then Parent
(Spec_Decl
) = Parent
(Body_Decl
);
456 end Is_Non_Loading_Expression_Function
;
462 function Must_Inline
return Inline_Level_Type
is
467 -- Check if call is in main unit
469 Scop
:= Current_Scope
;
471 -- Do not try to inline if scope is standard. This could happen, for
472 -- example, for a call to Add_Global_Declaration, and it causes
473 -- trouble to try to inline at this level.
475 if Scop
= Standard_Standard
then
479 -- Otherwise lookup scope stack to outer scope
481 while Scope
(Scop
) /= Standard_Standard
482 and then not Is_Child_Unit
(Scop
)
484 Scop
:= Scope
(Scop
);
487 Comp
:= Parent
(Scop
);
488 while Nkind
(Comp
) /= N_Compilation_Unit
loop
489 Comp
:= Parent
(Comp
);
492 -- If the call is in the main unit, inline the call and compile the
493 -- package of the subprogram to find more calls to be inlined.
495 if Comp
= Cunit
(Main_Unit
)
496 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
499 return Inline_Package
;
502 -- The call is not in the main unit. See if it is in some subprogram
503 -- that can be inlined outside its unit. If so, inline the call and,
504 -- if the inlining level is set to 1, stop there; otherwise also
505 -- compile the package as above.
507 Scop
:= Current_Scope
;
508 while Scope
(Scop
) /= Standard_Standard
509 and then not Is_Child_Unit
(Scop
)
511 if Is_Overloadable
(Scop
)
512 and then Is_Inlined
(Scop
)
513 and then not Is_Nested
(Scop
)
517 if Inline_Level
= 1 then
520 return Inline_Package
;
524 Scop
:= Scope
(Scop
);
532 Level
: Inline_Level_Type
;
534 -- Start of processing for Add_Inlined_Body
537 Append_New_Elmt
(N
, To
=> Backend_Calls
);
539 -- Skip subprograms that cannot or need not be inlined outside their
540 -- unit or parent subprogram.
542 if Is_Abstract_Subprogram
(E
)
543 or else Convention
(E
) = Convention_Protected
544 or else In_Main_Unit_Or_Subunit
(E
)
545 or else Is_Nested
(E
)
550 -- Find out whether the call must be inlined. Unless the result is
551 -- Dont_Inline, Must_Inline also creates an edge for the call in the
552 -- callgraph; however, it will not be activated until after Is_Called
553 -- is set on the subprogram.
555 Level
:= Must_Inline
;
557 if Level
= Dont_Inline
then
561 -- If a previous call to the subprogram has been inlined, nothing to do
563 if Is_Called
(E
) then
567 -- If the subprogram is an instance, then inline the instance
569 if Is_Generic_Instance
(E
) then
570 Add_Inlined_Instance
(E
);
573 -- Mark the subprogram as called
577 -- If the call was generated by the compiler and is to a subprogram in
578 -- a run-time unit, we need to suppress debugging information for it,
579 -- so that the code that is eventually inlined will not affect the
580 -- debugging of the program. We do not do it if the call comes from
581 -- source because, even if the call is inlined, the user may expect it
582 -- to be present in the debugging information.
584 if not Comes_From_Source
(N
)
585 and then In_Extended_Main_Source_Unit
(N
)
586 and then Is_Predefined_Unit
(Get_Source_Unit
(E
))
588 Set_Needs_Debug_Info
(E
, False);
591 -- If the subprogram is an expression function, or is completed by one
592 -- where both the spec and body are in the same context, then there is
593 -- no need to load any package body since the body of the function is
596 if Is_Non_Loading_Expression_Function
(E
) then
600 -- Find unit containing E, and add to list of inlined bodies if needed.
601 -- Library-level functions must be handled specially, because there is
602 -- no enclosing package to retrieve. In this case, it is the body of
603 -- the function that will have to be loaded.
606 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
610 Inlined_Bodies
.Increment_Last
;
611 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
614 pragma Assert
(Ekind
(Pack
) = E_Package
);
616 -- If the subprogram is within an instance, inline the instance
618 if Comes_From_Source
(E
) then
621 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
622 exit when Is_Generic_Instance
(Inst
);
623 Inst
:= Scope
(Inst
);
627 and then Is_Generic_Instance
(Inst
)
628 and then not Is_Called
(Inst
)
630 Inst_Decl
:= Unit_Declaration_Node
(Inst
);
632 -- Do not inline the instance if the body already exists,
633 -- or the instance node is simply missing.
635 if Present
(Corresponding_Body
(Inst_Decl
))
636 or else (Nkind
(Parent
(Inst_Decl
)) /= N_Compilation_Unit
637 and then No
(Next
(Inst_Decl
)))
639 Set_Is_Called
(Inst
);
641 Add_Inlined_Instance
(Inst
);
646 -- If the unit containing E is an instance, nothing more to do
648 if Is_Generic_Instance
(Pack
) then
651 -- Do not inline the package if the subprogram is an init proc
652 -- or other internally generated subprogram, because in that
653 -- case the subprogram body appears in the same unit that
654 -- declares the type, and that body is visible to the back end.
655 -- Do not inline it either if it is in the main unit.
656 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
657 -- calls if the back end takes care of inlining the call.
658 -- Note that Level is in Inline_Call | Inline_Package here.
660 elsif ((Level
= Inline_Call
661 and then Has_Pragma_Inline_Always
(E
)
662 and then Back_End_Inlining
)
663 or else Level
= Inline_Package
)
664 and then not Is_Inlined
(Pack
)
665 and then not Is_Internal
(E
)
666 and then not In_Main_Unit_Or_Subunit
(Pack
)
668 Set_Is_Inlined
(Pack
);
669 Inlined_Bodies
.Increment_Last
;
670 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
674 -- Ensure that Analyze_Inlined_Bodies will be invoked after
675 -- completing the analysis of the current unit.
677 Inline_Processing_Required
:= True;
679 end Add_Inlined_Body
;
681 --------------------------
682 -- Add_Inlined_Instance --
683 --------------------------
685 procedure Add_Inlined_Instance
(E
: Entity_Id
) is
686 Decl_Node
: constant Node_Id
:= Unit_Declaration_Node
(E
);
690 -- This machinery is only used with back-end inlining
692 if not Back_End_Inlining
then
696 -- Register the instance in the list
698 Append_New_Elmt
(Decl_Node
, To
=> Backend_Instances
);
700 -- Retrieve the index of its corresponding pending instantiation
701 -- and mark this corresponding pending instantiation as needed.
703 Index
:= To_Pending_Instantiations
.Get
(Decl_Node
);
705 Called_Pending_Instantiations
.Append
(Index
);
707 pragma Assert
(False);
712 end Add_Inlined_Instance
;
714 ----------------------------
715 -- Add_Inlined_Subprogram --
716 ----------------------------
718 procedure Add_Inlined_Subprogram
(E
: Entity_Id
) is
719 Decl
: constant Node_Id
:= Parent
(Declaration_Node
(E
));
720 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
722 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
723 -- Append Subp to the list of subprograms inlined by the backend
725 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
726 -- Append Subp to the list of subprograms that cannot be inlined by
729 -----------------------------------------
730 -- Register_Backend_Inlined_Subprogram --
731 -----------------------------------------
733 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
735 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
736 end Register_Backend_Inlined_Subprogram
;
738 ---------------------------------------------
739 -- Register_Backend_Not_Inlined_Subprogram --
740 ---------------------------------------------
742 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
744 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
745 end Register_Backend_Not_Inlined_Subprogram
;
747 -- Start of processing for Add_Inlined_Subprogram
750 -- We can inline the subprogram if its unit is known to be inlined or is
751 -- an instance whose body will be analyzed anyway or the subprogram was
752 -- generated as a body by the compiler (for example an initialization
753 -- procedure) or its declaration was provided along with the body (for
754 -- example an expression function) and it does not declare types with
755 -- nontrivial initialization procedures.
757 if (Is_Inlined
(Pack
)
758 or else Is_Generic_Instance
(Pack
)
759 or else Nkind
(Decl
) = N_Subprogram_Body
760 or else Present
(Corresponding_Body
(Decl
)))
761 and then not Has_Initialized_Type
(E
)
763 Register_Backend_Inlined_Subprogram
(E
);
765 if No
(Last_Inlined
) then
766 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
768 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
774 Register_Backend_Not_Inlined_Subprogram
(E
);
776 end Add_Inlined_Subprogram
;
778 --------------------------------
779 -- Add_Pending_Instantiation --
780 --------------------------------
782 procedure Add_Pending_Instantiation
(Inst
: Node_Id
; Act_Decl
: Node_Id
) is
783 Act_Decl_Id
: Entity_Id
;
787 -- Here is a defense against a ludicrous number of instantiations
788 -- caused by a circular set of instantiation attempts.
790 if Pending_Instantiations
.Last
+ 1 >= Maximum_Instantiations
then
791 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
792 Error_Msg_N
("too many instantiations, exceeds max of^", Inst
);
793 Error_Msg_N
("\limit can be changed using -gnateinn switch", Inst
);
794 raise Unrecoverable_Error
;
797 -- Capture the body of the generic instantiation along with its context
798 -- for later processing by Instantiate_Bodies.
800 Pending_Instantiations
.Append
801 ((Act_Decl
=> Act_Decl
,
802 Config_Switches
=> Save_Config_Switches
,
803 Current_Sem_Unit
=> Current_Sem_Unit
,
804 Expander_Status
=> Expander_Active
,
806 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
807 Scope_Suppress
=> Scope_Suppress
,
808 Warnings
=> Save_Warnings
));
810 -- With back-end inlining, also associate the index to the instantiation
812 if Back_End_Inlining
then
813 Act_Decl_Id
:= Defining_Entity
(Act_Decl
);
814 Index
:= Pending_Instantiations
.Last
;
816 To_Pending_Instantiations
.Set
(Act_Decl
, Index
);
818 -- If an instantiation is in the main unit or subunit, or is a nested
819 -- subprogram, then its body is needed as per the analysis done in
820 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
822 if In_Main_Unit_Or_Subunit
(Act_Decl_Id
)
823 or else (Is_Subprogram
(Act_Decl_Id
)
824 and then Is_Nested
(Act_Decl_Id
))
826 Called_Pending_Instantiations
.Append
(Index
);
828 Set_Is_Called
(Act_Decl_Id
);
831 end Add_Pending_Instantiation
;
833 ------------------------
834 -- Add_Scope_To_Clean --
835 ------------------------
837 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
838 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
842 -- If the instance appears in a library-level package declaration,
843 -- all finalization is global, and nothing needs doing here.
845 if Scop
= Standard_Standard
then
849 -- If the instance is within a generic unit, no finalization code
850 -- can be generated. Note that at this point all bodies have been
851 -- analyzed, and the scope stack itself is not present, and the flag
852 -- Inside_A_Generic is not set.
859 while Present
(S
) and then S
/= Standard_Standard
loop
860 if Is_Generic_Unit
(S
) then
868 Elmt
:= First_Elmt
(To_Clean
);
869 while Present
(Elmt
) loop
870 if Node
(Elmt
) = Scop
then
877 Append_Elmt
(Scop
, To_Clean
);
878 end Add_Scope_To_Clean
;
884 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
885 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
889 -- Initialize entry in Inlined table
891 procedure New_Entry
is
893 Inlined
.Increment_Last
;
894 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
895 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
896 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
897 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
898 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
901 -- Start of processing for Add_Subp
904 if Hash_Headers
(Index
) = No_Subp
then
906 Hash_Headers
(Index
) := Inlined
.Last
;
910 J
:= Hash_Headers
(Index
);
911 while J
/= No_Subp
loop
912 if Inlined
.Table
(J
).Name
= E
then
916 J
:= Inlined
.Table
(J
).Next
;
920 -- On exit, subprogram was not found. Enter in table. Index is
921 -- the current last entry on the hash chain.
924 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
929 ----------------------------
930 -- Analyze_Inlined_Bodies --
931 ----------------------------
933 procedure Analyze_Inlined_Bodies
is
940 type Pending_Index
is new Nat
;
942 package Pending_Inlined
is new Table
.Table
(
943 Table_Component_Type
=> Subp_Index
,
944 Table_Index_Type
=> Pending_Index
,
945 Table_Low_Bound
=> 1,
946 Table_Initial
=> Alloc
.Inlined_Initial
,
947 Table_Increment
=> Alloc
.Inlined_Increment
,
948 Table_Name
=> "Pending_Inlined");
949 -- The workpile used to compute the transitive closure
951 -- Start of processing for Analyze_Inlined_Bodies
954 if Serious_Errors_Detected
= 0 then
955 Push_Scope
(Standard_Standard
);
958 while J
<= Inlined_Bodies
.Last
959 and then Serious_Errors_Detected
= 0
961 Pack
:= Inlined_Bodies
.Table
(J
);
963 and then Scope
(Pack
) /= Standard_Standard
964 and then not Is_Child_Unit
(Pack
)
966 Pack
:= Scope
(Pack
);
969 Comp_Unit
:= Parent
(Pack
);
970 while Present
(Comp_Unit
)
971 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
973 Comp_Unit
:= Parent
(Comp_Unit
);
976 -- Load the body if it exists and contains inlineable entities,
977 -- unless it is the main unit, or is an instance whose body has
978 -- already been analyzed.
980 if Present
(Comp_Unit
)
981 and then Comp_Unit
/= Cunit
(Main_Unit
)
982 and then Body_Required
(Comp_Unit
)
984 (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
986 (No
(Corresponding_Body
(Unit
(Comp_Unit
)))
987 and then Body_Needed_For_Inlining
988 (Defining_Entity
(Unit
(Comp_Unit
)))))
991 Bname
: constant Unit_Name_Type
:=
992 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
997 if not Is_Loaded
(Bname
) then
998 Style_Check
:= False;
999 Load_Needed_Body
(Comp_Unit
, OK
);
1003 -- Warn that a body was not available for inlining
1006 Error_Msg_Unit_1
:= Bname
;
1008 ("one or more inlined subprograms accessed in $!??",
1011 Get_File_Name
(Bname
, Subunit
=> False);
1012 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
1020 if J
> Inlined_Bodies
.Last
then
1022 -- The analysis of required bodies may have produced additional
1023 -- generic instantiations. To obtain further inlining, we need
1024 -- to perform another round of generic body instantiations.
1028 -- Symmetrically, the instantiation of required generic bodies
1029 -- may have caused additional bodies to be inlined. To obtain
1030 -- further inlining, we keep looping over the inlined bodies.
1034 -- The list of inlined subprograms is an overestimate, because it
1035 -- includes inlined functions called from functions that are compiled
1036 -- as part of an inlined package, but are not themselves called. An
1037 -- accurate computation of just those subprograms that are needed
1038 -- requires that we perform a transitive closure over the call graph,
1039 -- starting from calls in the main compilation unit.
1041 for Index
in Inlined
.First
.. Inlined
.Last
loop
1042 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
1044 -- This means that Add_Inlined_Body added the subprogram to the
1045 -- table but wasn't able to handle its code unit. Do nothing.
1047 Inlined
.Table
(Index
).Processed
:= True;
1049 elsif Inlined
.Table
(Index
).Main_Call
then
1050 Pending_Inlined
.Increment_Last
;
1051 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
1052 Inlined
.Table
(Index
).Processed
:= True;
1055 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
1059 -- Iterate over the workpile until it is emptied, propagating the
1060 -- Is_Called flag to the successors of the processed subprogram.
1062 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
1063 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
1064 Pending_Inlined
.Decrement_Last
;
1066 S
:= Inlined
.Table
(Subp
).First_Succ
;
1068 while S
/= No_Succ
loop
1069 Subp
:= Successors
.Table
(S
).Subp
;
1071 if not Inlined
.Table
(Subp
).Processed
then
1072 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
1073 Pending_Inlined
.Increment_Last
;
1074 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
1075 Inlined
.Table
(Subp
).Processed
:= True;
1078 S
:= Successors
.Table
(S
).Next
;
1082 -- Finally add the called subprograms to the list of inlined
1083 -- subprograms for the unit.
1085 for Index
in Inlined
.First
.. Inlined
.Last
loop
1086 if Is_Called
(Inlined
.Table
(Index
).Name
) then
1087 Add_Inlined_Subprogram
(Inlined
.Table
(Index
).Name
);
1093 end Analyze_Inlined_Bodies
;
1095 --------------------------
1096 -- Build_Body_To_Inline --
1097 --------------------------
1099 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1100 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1101 Analysis_Status
: constant Boolean := Full_Analysis
;
1102 Original_Body
: Node_Id
;
1103 Body_To_Analyze
: Node_Id
;
1104 Max_Size
: constant := 10;
1106 function Has_Extended_Return
return Boolean;
1107 -- This function returns True if the subprogram has an extended return
1110 function Has_Pending_Instantiation
return Boolean;
1111 -- If some enclosing body contains instantiations that appear before
1112 -- the corresponding generic body, the enclosing body has a freeze node
1113 -- so that it can be elaborated after the generic itself. This might
1114 -- conflict with subsequent inlinings, so that it is unsafe to try to
1115 -- inline in such a case.
1117 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
1118 -- This function is called only in GNATprove mode, and it returns
1119 -- True if the subprogram has no return statement or a single return
1120 -- statement as last statement. It returns False for subprogram with
1121 -- a single return as last statement inside one or more blocks, as
1122 -- inlining would generate gotos in that case as well (although the
1123 -- goto is useless in that case).
1125 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
1126 -- If the body of the subprogram includes a call that returns an
1127 -- unconstrained type, the secondary stack is involved, and it is
1128 -- not worth inlining.
1130 -------------------------
1131 -- Has_Extended_Return --
1132 -------------------------
1134 function Has_Extended_Return
return Boolean is
1135 Body_To_Inline
: constant Node_Id
:= N
;
1137 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1138 -- Returns OK on node N if this is not an extended return statement
1144 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1147 when N_Extended_Return_Statement
=>
1150 -- Skip locally declared subprogram bodies inside the body to
1151 -- inline, as the return statements inside those do not count.
1153 when N_Subprogram_Body
=>
1154 if N
= Body_To_Inline
then
1165 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1167 -- Start of processing for Has_Extended_Return
1170 return Check_All_Returns
(N
) /= OK
;
1171 end Has_Extended_Return
;
1173 -------------------------------
1174 -- Has_Pending_Instantiation --
1175 -------------------------------
1177 function Has_Pending_Instantiation
return Boolean is
1182 while Present
(S
) loop
1183 if Is_Compilation_Unit
(S
)
1184 or else Is_Child_Unit
(S
)
1188 elsif Ekind
(S
) = E_Package
1189 and then Has_Forward_Instantiation
(S
)
1198 end Has_Pending_Instantiation
;
1200 -----------------------------------------
1201 -- Has_Single_Return_In_GNATprove_Mode --
1202 -----------------------------------------
1204 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
1205 Body_To_Inline
: constant Node_Id
:= N
;
1206 Last_Statement
: Node_Id
:= Empty
;
1208 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1209 -- Returns OK on node N if this is not a return statement different
1210 -- from the last statement in the subprogram.
1216 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1219 when N_Extended_Return_Statement
1220 | N_Simple_Return_Statement
1222 if N
= Last_Statement
then
1228 -- Skip locally declared subprogram bodies inside the body to
1229 -- inline, as the return statements inside those do not count.
1231 when N_Subprogram_Body
=>
1232 if N
= Body_To_Inline
then
1243 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1245 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1248 -- Retrieve the last statement
1250 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
1252 -- Check that the last statement is the only possible return
1253 -- statement in the subprogram.
1255 return Check_All_Returns
(N
) = OK
;
1256 end Has_Single_Return_In_GNATprove_Mode
;
1258 --------------------------
1259 -- Uses_Secondary_Stack --
1260 --------------------------
1262 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
1263 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
1264 -- Look for function calls that return an unconstrained type
1270 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
1272 if Nkind
(N
) = N_Function_Call
1273 and then Is_Entity_Name
(Name
(N
))
1274 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
1275 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
1278 ("cannot inline & (call returns unconstrained type)?",
1286 function Check_Calls
is new Traverse_Func
(Check_Call
);
1289 return Check_Calls
(Bod
) = Abandon
;
1290 end Uses_Secondary_Stack
;
1292 -- Start of processing for Build_Body_To_Inline
1295 -- Return immediately if done already
1297 if Nkind
(Decl
) = N_Subprogram_Declaration
1298 and then Present
(Body_To_Inline
(Decl
))
1302 -- Subprograms that have return statements in the middle of the body are
1303 -- inlined with gotos. GNATprove does not currently support gotos, so
1304 -- we prevent such inlining.
1306 elsif GNATprove_Mode
1307 and then not Has_Single_Return_In_GNATprove_Mode
1309 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1312 -- Functions that return controlled types cannot currently be inlined
1313 -- because they require secondary stack handling; controlled actions
1314 -- may also interfere in complex ways with inlining.
1316 elsif Ekind
(Spec_Id
) = E_Function
1317 and then Needs_Finalization
(Etype
(Spec_Id
))
1320 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1324 if Present
(Declarations
(N
))
1325 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1330 if Present
(Handled_Statement_Sequence
(N
)) then
1331 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1333 ("cannot inline& (exception handler)?",
1334 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1338 elsif Has_Excluded_Statement
1339 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1345 -- We do not inline a subprogram that is too large, unless it is marked
1346 -- Inline_Always or we are in GNATprove mode. This pragma does not
1347 -- suppress the other checks on inlining (forbidden declarations,
1350 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1351 and then List_Length
1352 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1354 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1358 if Has_Pending_Instantiation
then
1360 ("cannot inline& (forward instance within enclosing body)?",
1365 -- Within an instance, the body to inline must be treated as a nested
1366 -- generic, so that the proper global references are preserved.
1368 -- Note that we do not do this at the library level, because it is not
1369 -- needed, and furthermore this causes trouble if front-end inlining
1370 -- is activated (-gnatN).
1372 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1373 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1374 Original_Body
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
1376 Original_Body
:= Copy_Separate_Tree
(N
);
1379 -- We need to capture references to the formals in order to substitute
1380 -- the actuals at the point of inlining, i.e. instantiation. To treat
1381 -- the formals as globals to the body to inline, we nest it within a
1382 -- dummy parameterless subprogram, declared within the real one. To
1383 -- avoid generating an internal name (which is never public, and which
1384 -- affects serial numbers of other generated names), we use an internal
1385 -- symbol that cannot conflict with user declarations.
1387 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1388 Set_Defining_Unit_Name
1389 (Specification
(Original_Body
),
1390 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1391 Set_Corresponding_Spec
(Original_Body
, Empty
);
1393 -- Remove all aspects/pragmas that have no meaning in an inlined body
1395 Remove_Aspects_And_Pragmas
(Original_Body
);
1398 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
1400 -- Set return type of function, which is also global and does not need
1403 if Ekind
(Spec_Id
) = E_Function
then
1404 Set_Result_Definition
1405 (Specification
(Body_To_Analyze
),
1406 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1409 if No
(Declarations
(N
)) then
1410 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1412 Append
(Body_To_Analyze
, Declarations
(N
));
1415 -- The body to inline is preanalyzed. In GNATprove mode we must disable
1416 -- full analysis as well so that light expansion does not take place
1417 -- either, and name resolution is unaffected.
1419 Expander_Mode_Save_And_Set
(False);
1420 Full_Analysis
:= False;
1422 Analyze
(Body_To_Analyze
);
1423 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1424 Save_Global_References
(Original_Body
);
1426 Remove
(Body_To_Analyze
);
1428 Expander_Mode_Restore
;
1429 Full_Analysis
:= Analysis_Status
;
1431 -- Restore environment if previously saved
1433 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1437 -- Functions that return unconstrained composite types require
1438 -- secondary stack handling, and cannot currently be inlined, unless
1439 -- all return statements return a local variable that is the first
1440 -- local declaration in the body. We had to delay this check until
1441 -- the body of the function is analyzed since Has_Single_Return()
1442 -- requires a minimum decoration.
1444 if Ekind
(Spec_Id
) = E_Function
1445 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1446 and then not Is_Access_Type
(Etype
(Spec_Id
))
1447 and then not Is_Constrained
(Etype
(Spec_Id
))
1449 if not Has_Single_Return
(Body_To_Analyze
)
1451 -- Skip inlining if the function returns an unconstrained type
1452 -- using an extended return statement, since this part of the
1453 -- new inlining model is not yet supported by the current
1454 -- implementation. ???
1456 or else (Returns_Unconstrained_Type
(Spec_Id
)
1457 and then Has_Extended_Return
)
1460 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1464 -- If secondary stack is used, there is no point in inlining. We have
1465 -- already issued the warning in this case, so nothing to do.
1467 elsif Uses_Secondary_Stack
(Body_To_Analyze
) then
1471 Set_Body_To_Inline
(Decl
, Original_Body
);
1472 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1473 Set_Is_Inlined
(Spec_Id
);
1474 end Build_Body_To_Inline
;
1476 -------------------------------------------
1477 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1478 -------------------------------------------
1480 function Call_Can_Be_Inlined_In_GNATprove_Mode
1482 Subp
: Entity_Id
) return Boolean
1488 F
:= First_Formal
(Subp
);
1489 A
:= First_Actual
(N
);
1490 while Present
(F
) loop
1491 if Ekind
(F
) /= E_Out_Parameter
1492 and then not Same_Type
(Etype
(F
), Etype
(A
))
1494 (Is_By_Reference_Type
(Etype
(A
))
1495 or else Is_Limited_Type
(Etype
(A
)))
1505 end Call_Can_Be_Inlined_In_GNATprove_Mode
;
1507 --------------------------------------
1508 -- Can_Be_Inlined_In_GNATprove_Mode --
1509 --------------------------------------
1511 function Can_Be_Inlined_In_GNATprove_Mode
1512 (Spec_Id
: Entity_Id
;
1513 Body_Id
: Entity_Id
) return Boolean
1515 function Has_Formal_Or_Result_Of_Deep_Type
1516 (Id
: Entity_Id
) return Boolean;
1517 -- Returns true if the subprogram has at least one formal parameter or
1518 -- a return type of a deep type: either an access type or a composite
1519 -- type containing an access type.
1521 function Has_Formal_With_Discriminant_Dependent_Fields
1522 (Id
: Entity_Id
) return Boolean;
1523 -- Returns true if the subprogram has at least one formal parameter of
1524 -- an unconstrained record type with per-object constraints on component
1527 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1528 -- Return True if subprogram Id has any contract. The presence of
1529 -- Extensions_Visible or Volatile_Function is also considered as a
1532 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1533 -- Return True if subprogram Id defines a compilation unit
1534 -- Shouldn't this be in Sem_Aux???
1536 function In_Package_Spec
(Id
: Entity_Id
) return Boolean;
1537 -- Return True if subprogram Id is defined in the package specification,
1538 -- either its visible or private part.
1540 function Maybe_Traversal_Function
(Id
: Entity_Id
) return Boolean;
1541 -- Return True if subprogram Id could be a traversal function, as
1542 -- defined in SPARK RM 3.10. This is only a safe approximation, as the
1543 -- knowledge of the SPARK boundary is needed to determine exactly
1544 -- traversal functions.
1546 ---------------------------------------
1547 -- Has_Formal_Or_Result_Of_Deep_Type --
1548 ---------------------------------------
1550 function Has_Formal_Or_Result_Of_Deep_Type
1551 (Id
: Entity_Id
) return Boolean
1553 function Is_Deep
(Typ
: Entity_Id
) return Boolean;
1554 -- Return True if Typ is deep: either an access type or a composite
1555 -- type containing an access type.
1561 function Is_Deep
(Typ
: Entity_Id
) return Boolean is
1563 case Type_Kind
'(Ekind (Typ)) is
1570 return Is_Deep (Component_Type (Typ));
1574 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
1576 while Present (Comp) loop
1577 if Is_Deep (Etype (Comp)) then
1580 Next_Component_Or_Discriminant (Comp);
1586 | E_String_Literal_Subtype
1596 | E_Limited_Private_Type
1597 | E_Limited_Private_Subtype
1599 -- Conservatively consider that the type might be deep if
1600 -- its completion has not been seen yet.
1602 if No (Underlying_Type (Typ)) then
1605 -- Do not peek under a private type if its completion has
1606 -- SPARK_Mode Off. In such a case, a deep type is considered
1607 -- by GNATprove to be not deep.
1609 elsif Present (Full_View (Typ))
1610 and then Present (SPARK_Pragma (Full_View (Typ)))
1611 and then Get_SPARK_Mode_From_Annotation
1612 (SPARK_Pragma (Full_View (Typ))) = Off
1616 -- Otherwise peek under the private type.
1619 return Is_Deep (Underlying_Type (Typ));
1626 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1628 Formal_Typ : Entity_Id;
1630 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
1633 -- Inspect all parameters of the subprogram looking for a formal
1636 Formal := First_Formal (Subp_Id);
1637 while Present (Formal) loop
1638 Formal_Typ := Etype (Formal);
1640 if Is_Deep (Formal_Typ) then
1644 Next_Formal (Formal);
1647 -- Check whether this is a function whose return type is deep
1649 if Ekind (Subp_Id) = E_Function
1650 and then Is_Deep (Etype (Subp_Id))
1656 end Has_Formal_Or_Result_Of_Deep_Type;
1658 ---------------------------------------------------
1659 -- Has_Formal_With_Discriminant_Dependent_Fields --
1660 ---------------------------------------------------
1662 function Has_Formal_With_Discriminant_Dependent_Fields
1663 (Id : Entity_Id) return Boolean
1665 function Has_Discriminant_Dependent_Component
1666 (Typ : Entity_Id) return Boolean;
1667 -- Determine whether unconstrained record type Typ has at least one
1668 -- component that depends on a discriminant.
1670 ------------------------------------------
1671 -- Has_Discriminant_Dependent_Component --
1672 ------------------------------------------
1674 function Has_Discriminant_Dependent_Component
1675 (Typ : Entity_Id) return Boolean
1680 -- Inspect all components of the record type looking for one that
1681 -- depends on a discriminant.
1683 Comp := First_Component (Typ);
1684 while Present (Comp) loop
1685 if Has_Discriminant_Dependent_Constraint (Comp) then
1689 Next_Component (Comp);
1693 end Has_Discriminant_Dependent_Component;
1697 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1699 Formal_Typ : Entity_Id;
1701 -- Start of processing for
1702 -- Has_Formal_With_Discriminant_Dependent_Fields
1705 -- Inspect all parameters of the subprogram looking for a formal
1706 -- of an unconstrained record type with at least one discriminant
1707 -- dependent component.
1709 Formal := First_Formal (Subp_Id);
1710 while Present (Formal) loop
1711 Formal_Typ := Etype (Formal);
1713 if Is_Record_Type (Formal_Typ)
1714 and then not Is_Constrained (Formal_Typ)
1715 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1720 Next_Formal (Formal);
1724 end Has_Formal_With_Discriminant_Dependent_Fields;
1726 -----------------------
1727 -- Has_Some_Contract --
1728 -----------------------
1730 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1734 -- A call to an expression function may precede the actual body which
1735 -- is inserted at the end of the enclosing declarations. Ensure that
1736 -- the related entity is decorated before inspecting the contract.
1738 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1739 Items := Contract (Id);
1741 -- Note that Classifications is not Empty when Extensions_Visible
1742 -- or Volatile_Function is present, which causes such subprograms
1743 -- to be considered to have a contract here. This is fine as we
1744 -- want to avoid inlining these too.
1746 return Present (Items)
1747 and then (Present (Pre_Post_Conditions (Items)) or else
1748 Present (Contract_Test_Cases (Items)) or else
1749 Present (Classifications (Items)));
1753 end Has_Some_Contract;
1755 ---------------------
1756 -- In_Package_Spec --
1757 ---------------------
1759 function In_Package_Spec (Id : Entity_Id) return Boolean is
1760 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1761 -- Parent of the subprogram's declaration
1764 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1765 end In_Package_Spec;
1767 ------------------------
1768 -- Is_Unit_Subprogram --
1769 ------------------------
1771 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1772 Decl : Node_Id := Parent (Parent (Id));
1774 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1775 Decl := Parent (Decl);
1778 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1779 end Is_Unit_Subprogram;
1781 ------------------------------
1782 -- Maybe_Traversal_Function --
1783 ------------------------------
1785 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
1787 return Ekind (Id) = E_Function
1789 -- Only traversal functions return an anonymous access-to-object
1792 and then Is_Anonymous_Access_Type (Etype (Id));
1793 end Maybe_Traversal_Function;
1795 -- Local declarations
1798 -- Procedure or function entity for the subprogram
1800 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1803 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1805 if Present (Spec_Id) then
1811 -- Only local subprograms without contracts are inlined in GNATprove
1812 -- mode, as these are the subprograms which a user is not interested in
1813 -- analyzing in isolation, but rather in the context of their call. This
1814 -- is a convenient convention, that could be changed for an explicit
1815 -- pragma/aspect one day.
1817 -- In a number of special cases, inlining is not desirable or not
1818 -- possible, see below.
1820 -- Do not inline unit-level subprograms
1822 if Is_Unit_Subprogram (Id) then
1825 -- Do not inline subprograms declared in package specs, because they are
1826 -- not local, i.e. can be called either from anywhere (if declared in
1827 -- visible part) or from the child units (if declared in private part).
1829 elsif In_Package_Spec (Id) then
1832 -- Do not inline subprograms declared in other units. This is important
1833 -- in particular for subprograms defined in the private part of a
1834 -- package spec, when analyzing one of its child packages, as otherwise
1835 -- we issue spurious messages about the impossibility to inline such
1838 elsif not In_Extended_Main_Code_Unit (Id) then
1841 -- Do not inline dispatching operations, as only their static calls
1842 -- can be analyzed in context, and not their dispatching calls.
1844 elsif Is_Dispatching_Operation (Id) then
1847 -- Do not inline subprograms marked No_Return, possibly used for
1848 -- signaling errors, which GNATprove handles specially.
1850 elsif No_Return (Id) then
1853 -- Do not inline subprograms that have a contract on the spec or the
1854 -- body. Use the contract(s) instead in GNATprove. This also prevents
1855 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1857 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1859 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1863 -- Do not inline expression functions, which are directly inlined at the
1866 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1868 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1872 -- Do not inline generic subprogram instances. The visibility rules of
1873 -- generic instances plays badly with inlining.
1875 elsif Is_Generic_Instance (Spec_Id) then
1878 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1879 -- the subprogram body, a similar check is performed after the body
1880 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1882 elsif Present (Spec_Id)
1884 (No (SPARK_Pragma (Spec_Id))
1886 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1890 -- Subprograms in generic instances are currently not inlined, to avoid
1891 -- problems with inlining of standard library subprograms.
1893 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1896 -- Do not inline subprograms and entries defined inside protected types,
1897 -- which typically are not helper subprograms, which also avoids getting
1898 -- spurious messages on calls that cannot be inlined.
1900 elsif Within_Protected_Type (Id) then
1903 -- Do not inline predicate functions (treated specially by GNATprove)
1905 elsif Is_Predicate_Function (Id) then
1908 -- Do not inline subprograms with a parameter of an unconstrained
1909 -- record type if it has discrimiant dependent fields. Indeed, with
1910 -- such parameters, the frontend cannot always ensure type compliance
1911 -- in record component accesses (in particular with records containing
1914 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1917 -- Do not inline subprograms with a formal parameter or return type of
1918 -- a deep type, as in that case inlining might generate code that
1919 -- violates borrow-checking rules of SPARK 3.10 even if the original
1922 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
1925 -- Do not inline subprograms which may be traversal functions. Such
1926 -- inlining introduces temporary variables of named access type for
1927 -- which assignments are move instead of borrow/observe, possibly
1928 -- leading to spurious errors when checking SPARK rules related to
1931 elsif Maybe_Traversal_Function (Id) then
1934 -- Otherwise, this is a subprogram declared inside the private part of a
1935 -- package, or inside a package body, or locally in a subprogram, and it
1936 -- does not have any contract. Inline it.
1941 end Can_Be_Inlined_In_GNATprove_Mode;
1947 procedure Cannot_Inline
1951 Is_Serious : Boolean := False)
1954 -- In GNATprove mode, inlining is the technical means by which the
1955 -- higher-level goal of contextual analysis is reached, so issue
1956 -- messages about failure to apply contextual analysis to a
1957 -- subprogram, rather than failure to inline it.
1960 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1963 Len1 : constant Positive :=
1964 String (String'("cannot inline"))'Length;
1965 Len2
: constant Positive :=
1966 String (String'("info: no contextual analysis of"))'Length;
1968 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1971 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1972 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1973 Msg (Msg'First + Len1 .. Msg'Last);
1974 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1979 pragma Assert (Msg (Msg'Last) = '?
');
1981 -- Legacy front-end inlining model
1983 if not Back_End_Inlining then
1985 -- Do not emit warning if this is a predefined unit which is not
1986 -- the main unit. With validity checks enabled, some predefined
1987 -- subprograms may contain nested subprograms and become ineligible
1990 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1991 and then not In_Extended_Main_Source_Unit (Subp)
1995 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1996 -- indicate that the subprogram is not always inlined by setting
1997 -- flag Is_Inlined_Always to False.
1999 elsif GNATprove_Mode then
2000 Set_Is_Inlined_Always (Subp, False);
2002 if Debug_Flag_Underscore_F then
2003 Error_Msg_NE (Msg, N, Subp);
2006 elsif Has_Pragma_Inline_Always (Subp) then
2008 -- Remove last character (question mark) to make this into an
2009 -- error, because the Inline_Always pragma cannot be obeyed.
2011 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2013 elsif Ineffective_Inline_Warnings then
2014 Error_Msg_NE (Msg & "p?", N, Subp);
2017 -- New semantics relying on back-end inlining
2019 elsif Is_Serious then
2021 -- Remove last character (question mark) to make this into an error.
2023 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2025 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
2026 -- indicate that the subprogram is not always inlined by setting
2027 -- flag Is_Inlined_Always to False.
2029 elsif GNATprove_Mode then
2030 Set_Is_Inlined_Always (Subp, False);
2032 if Debug_Flag_Underscore_F then
2033 Error_Msg_NE (Msg, N, Subp);
2038 -- Do not emit warning if this is a predefined unit which is not
2039 -- the main unit. This behavior is currently provided for backward
2040 -- compatibility but it will be removed when we enforce the
2041 -- strictness of the new rules.
2043 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2044 and then not In_Extended_Main_Source_Unit (Subp)
2048 elsif Has_Pragma_Inline_Always (Subp) then
2050 -- Emit a warning if this is a call to a runtime subprogram
2051 -- which is located inside a generic. Previously this call
2052 -- was silently skipped.
2054 if Is_Generic_Instance (Subp) then
2056 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
2058 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
2059 Set_Is_Inlined (Subp, False);
2060 Error_Msg_NE (Msg & "p?", N, Subp);
2066 -- Remove last character (question mark) to make this into an
2067 -- error, because the Inline_Always pragma cannot be obeyed.
2069 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2072 Set_Is_Inlined (Subp, False);
2074 if Ineffective_Inline_Warnings then
2075 Error_Msg_NE (Msg & "p?", N, Subp);
2081 --------------------------------------------
2082 -- Check_And_Split_Unconstrained_Function --
2083 --------------------------------------------
2085 procedure Check_And_Split_Unconstrained_Function
2087 Spec_Id : Entity_Id;
2088 Body_Id : Entity_Id)
2090 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
2091 -- Use generic machinery to build an unexpanded body for the subprogram.
2092 -- This body is subsequently used for inline expansions at call sites.
2094 procedure Build_Return_Object_Formal
2098 -- Create a formal parameter for return object declaration Obj_Decl of
2099 -- an extended return statement and add it to list Formals.
2101 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
2102 -- Return true if we generate code for the function body N, the function
2103 -- body N has no local declarations and its unique statement is a single
2104 -- extended return statement with a handled statements sequence.
2106 procedure Copy_Formals
2108 Subp_Id : Entity_Id;
2110 -- Create new formal parameters from the formal parameters of subprogram
2111 -- Subp_Id and add them to list Formals.
2113 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
2114 -- Create a copy of return object declaration Obj_Decl of an extended
2115 -- return statement.
2117 procedure Split_Unconstrained_Function
2119 Spec_Id : Entity_Id);
2120 -- N is an inlined function body that returns an unconstrained type and
2121 -- has a single extended return statement. Split N in two subprograms:
2122 -- a procedure P' and a
function F
'. The formals of P' duplicate the
2123 -- formals of N plus an extra formal which is used to return a value;
2124 -- its body is composed by the declarations and list of statements
2125 -- of the extended return statement of N.
2127 --------------------------
2128 -- Build_Body_To_Inline --
2129 --------------------------
2131 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2132 procedure Generate_Subprogram_Body
2134 Body_To_Inline
: out Node_Id
);
2135 -- Generate a parameterless duplicate of subprogram body N. Note that
2136 -- occurrences of pragmas referencing the formals are removed since
2137 -- they have no meaning when the body is inlined and the formals are
2138 -- rewritten (the analysis of the non-inlined body will handle these
2139 -- pragmas). A new internal name is associated with Body_To_Inline.
2141 ------------------------------
2142 -- Generate_Subprogram_Body --
2143 ------------------------------
2145 procedure Generate_Subprogram_Body
2147 Body_To_Inline
: out Node_Id
)
2150 -- Within an instance, the body to inline must be treated as a
2151 -- nested generic so that proper global references are preserved.
2153 -- Note that we do not do this at the library level, because it
2154 -- is not needed, and furthermore this causes trouble if front
2155 -- end inlining is activated (-gnatN).
2158 and then Scope
(Current_Scope
) /= Standard_Standard
2161 Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
2163 -- ??? Shouldn't this use New_Copy_Tree? What about global
2164 -- references captured in the body to inline?
2166 Body_To_Inline
:= Copy_Separate_Tree
(N
);
2169 -- Remove aspects/pragmas that have no meaning in an inlined body
2171 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
2173 -- We need to capture references to the formals in order
2174 -- to substitute the actuals at the point of inlining, i.e.
2175 -- instantiation. To treat the formals as globals to the body to
2176 -- inline, we nest it within a dummy parameterless subprogram,
2177 -- declared within the real one.
2179 Set_Parameter_Specifications
2180 (Specification
(Body_To_Inline
), No_List
);
2182 -- A new internal name is associated with Body_To_Inline to avoid
2183 -- conflicts when the non-inlined body N is analyzed.
2185 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
2186 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
2187 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
2188 end Generate_Subprogram_Body
;
2192 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2193 Original_Body
: Node_Id
;
2194 Body_To_Analyze
: Node_Id
;
2196 -- Start of processing for Build_Body_To_Inline
2199 pragma Assert
(Current_Scope
= Spec_Id
);
2201 -- Within an instance, the body to inline must be treated as a nested
2202 -- generic, so that the proper global references are preserved. We
2203 -- do not do this at the library level, because it is not needed, and
2204 -- furthermore this causes trouble if front-end inlining is activated
2208 and then Scope
(Current_Scope
) /= Standard_Standard
2210 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
2213 -- Capture references to formals in order to substitute the actuals
2214 -- at the point of inlining or instantiation. To treat the formals
2215 -- as globals to the body to inline, nest the body within a dummy
2216 -- parameterless subprogram, declared within the real one.
2218 Generate_Subprogram_Body
(N
, Original_Body
);
2220 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
2222 -- Set return type of function, which is also global and does not
2223 -- need to be resolved.
2225 if Ekind
(Spec_Id
) = E_Function
then
2226 Set_Result_Definition
(Specification
(Body_To_Analyze
),
2227 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
2230 if No
(Declarations
(N
)) then
2231 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
2233 Append_To
(Declarations
(N
), Body_To_Analyze
);
2236 Preanalyze
(Body_To_Analyze
);
2238 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
2239 Save_Global_References
(Original_Body
);
2241 Remove
(Body_To_Analyze
);
2243 -- Restore environment if previously saved
2246 and then Scope
(Current_Scope
) /= Standard_Standard
2251 pragma Assert
(No
(Body_To_Inline
(Decl
)));
2252 Set_Body_To_Inline
(Decl
, Original_Body
);
2253 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
2254 end Build_Body_To_Inline
;
2256 --------------------------------
2257 -- Build_Return_Object_Formal --
2258 --------------------------------
2260 procedure Build_Return_Object_Formal
2265 Obj_Def
: constant Node_Id
:= Object_Definition
(Obj_Decl
);
2266 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2270 -- Build the type definition of the formal parameter. The use of
2271 -- New_Copy_Tree ensures that global references preserved in the
2272 -- case of generics.
2274 if Is_Entity_Name
(Obj_Def
) then
2275 Typ_Def
:= New_Copy_Tree
(Obj_Def
);
2277 Typ_Def
:= New_Copy_Tree
(Subtype_Mark
(Obj_Def
));
2282 -- Obj_Id : [out] Typ_Def
2284 -- Mode OUT should not be used when the return object is declared as
2285 -- a constant. Check the definition of the object declaration because
2286 -- the object has not been analyzed yet.
2289 Make_Parameter_Specification
(Loc
,
2290 Defining_Identifier
=>
2291 Make_Defining_Identifier
(Loc
, Chars
(Obj_Id
)),
2292 In_Present
=> False,
2293 Out_Present
=> not Constant_Present
(Obj_Decl
),
2294 Null_Exclusion_Present
=> False,
2295 Parameter_Type
=> Typ_Def
));
2296 end Build_Return_Object_Formal
;
2298 --------------------------------------
2299 -- Can_Split_Unconstrained_Function --
2300 --------------------------------------
2302 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean is
2303 Stmt
: constant Node_Id
:=
2304 First
(Statements
(Handled_Statement_Sequence
(N
)));
2308 -- No user defined declarations allowed in the function except inside
2309 -- the unique return statement; implicit labels are the only allowed
2312 Decl
:= First
(Declarations
(N
));
2313 while Present
(Decl
) loop
2314 if Nkind
(Decl
) /= N_Implicit_Label_Declaration
then
2321 -- We only split the inlined function when we are generating the code
2322 -- of its body; otherwise we leave duplicated split subprograms in
2323 -- the tree which (if referenced) generate wrong references at link
2326 return In_Extended_Main_Code_Unit
(N
)
2327 and then Present
(Stmt
)
2328 and then Nkind
(Stmt
) = N_Extended_Return_Statement
2329 and then No
(Next
(Stmt
))
2330 and then Present
(Handled_Statement_Sequence
(Stmt
));
2331 end Can_Split_Unconstrained_Function
;
2337 procedure Copy_Formals
2339 Subp_Id
: Entity_Id
;
2346 Formal
:= First_Formal
(Subp_Id
);
2347 while Present
(Formal
) loop
2348 Spec
:= Parent
(Formal
);
2350 -- Create an exact copy of the formal parameter. The use of
2351 -- New_Copy_Tree ensures that global references are preserved
2352 -- in case of generics.
2355 Make_Parameter_Specification
(Loc
,
2356 Defining_Identifier
=>
2357 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
2358 In_Present
=> In_Present
(Spec
),
2359 Out_Present
=> Out_Present
(Spec
),
2360 Null_Exclusion_Present
=> Null_Exclusion_Present
(Spec
),
2362 New_Copy_Tree
(Parameter_Type
(Spec
)),
2363 Expression
=> New_Copy_Tree
(Expression
(Spec
))));
2365 Next_Formal
(Formal
);
2369 ------------------------
2370 -- Copy_Return_Object --
2371 ------------------------
2373 function Copy_Return_Object
(Obj_Decl
: Node_Id
) return Node_Id
is
2374 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2377 -- The use of New_Copy_Tree ensures that global references are
2378 -- preserved in case of generics.
2381 Make_Object_Declaration
(Sloc
(Obj_Decl
),
2382 Defining_Identifier
=>
2383 Make_Defining_Identifier
(Sloc
(Obj_Id
), Chars
(Obj_Id
)),
2384 Aliased_Present
=> Aliased_Present
(Obj_Decl
),
2385 Constant_Present
=> Constant_Present
(Obj_Decl
),
2386 Null_Exclusion_Present
=> Null_Exclusion_Present
(Obj_Decl
),
2387 Object_Definition
=>
2388 New_Copy_Tree
(Object_Definition
(Obj_Decl
)),
2389 Expression
=> New_Copy_Tree
(Expression
(Obj_Decl
)));
2390 end Copy_Return_Object
;
2392 ----------------------------------
2393 -- Split_Unconstrained_Function --
2394 ----------------------------------
2396 procedure Split_Unconstrained_Function
2398 Spec_Id
: Entity_Id
)
2400 Loc
: constant Source_Ptr
:= Sloc
(N
);
2401 Ret_Stmt
: constant Node_Id
:=
2402 First
(Statements
(Handled_Statement_Sequence
(N
)));
2403 Ret_Obj
: constant Node_Id
:=
2404 First
(Return_Object_Declarations
(Ret_Stmt
));
2406 procedure Build_Procedure
2407 (Proc_Id
: out Entity_Id
;
2408 Decl_List
: out List_Id
);
2409 -- Build a procedure containing the statements found in the extended
2410 -- return statement of the unconstrained function body N.
2412 ---------------------
2413 -- Build_Procedure --
2414 ---------------------
2416 procedure Build_Procedure
2417 (Proc_Id
: out Entity_Id
;
2418 Decl_List
: out List_Id
)
2420 Formals
: constant List_Id
:= New_List
;
2421 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
2423 Body_Decls
: List_Id
:= No_List
;
2425 Proc_Body
: Node_Id
;
2426 Proc_Spec
: Node_Id
;
2429 -- Create formal parameters for the return object and all formals
2430 -- of the unconstrained function in order to pass their values to
2433 Build_Return_Object_Formal
2435 Obj_Decl
=> Ret_Obj
,
2436 Formals
=> Formals
);
2441 Formals
=> Formals
);
2443 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
2446 Make_Procedure_Specification
(Loc
,
2447 Defining_Unit_Name
=> Proc_Id
,
2448 Parameter_Specifications
=> Formals
);
2450 Decl_List
:= New_List
;
2452 Append_To
(Decl_List
,
2453 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
2455 -- Can_Convert_Unconstrained_Function checked that the function
2456 -- has no local declarations except implicit label declarations.
2457 -- Copy these declarations to the built procedure.
2459 if Present
(Declarations
(N
)) then
2460 Body_Decls
:= New_List
;
2462 Decl
:= First
(Declarations
(N
));
2463 while Present
(Decl
) loop
2464 pragma Assert
(Nkind
(Decl
) = N_Implicit_Label_Declaration
);
2466 Append_To
(Body_Decls
,
2467 Make_Implicit_Label_Declaration
(Loc
,
2468 Make_Defining_Identifier
(Loc
,
2469 Chars
=> Chars
(Defining_Identifier
(Decl
))),
2470 Label_Construct
=> Empty
));
2476 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Stmt
)));
2479 Make_Subprogram_Body
(Loc
,
2480 Specification
=> Copy_Subprogram_Spec
(Proc_Spec
),
2481 Declarations
=> Body_Decls
,
2482 Handled_Statement_Sequence
=>
2483 New_Copy_Tree
(Handled_Statement_Sequence
(Ret_Stmt
)));
2485 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
2486 Make_Defining_Identifier
(Loc
, Subp_Name
));
2488 Append_To
(Decl_List
, Proc_Body
);
2489 end Build_Procedure
;
2493 New_Obj
: constant Node_Id
:= Copy_Return_Object
(Ret_Obj
);
2495 Proc_Call
: Node_Id
;
2496 Proc_Id
: Entity_Id
;
2498 -- Start of processing for Split_Unconstrained_Function
2501 -- Build the associated procedure, analyze it and insert it before
2502 -- the function body N.
2505 Scope
: constant Entity_Id
:= Current_Scope
;
2506 Decl_List
: List_Id
;
2509 Build_Procedure
(Proc_Id
, Decl_List
);
2510 Insert_Actions
(N
, Decl_List
);
2511 Set_Is_Inlined
(Proc_Id
);
2515 -- Build the call to the generated procedure
2518 Actual_List
: constant List_Id
:= New_List
;
2522 Append_To
(Actual_List
,
2523 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
2525 Formal
:= First_Formal
(Spec_Id
);
2526 while Present
(Formal
) loop
2527 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
2529 -- Avoid spurious warning on unreferenced formals
2531 Set_Referenced
(Formal
);
2532 Next_Formal
(Formal
);
2536 Make_Procedure_Call_Statement
(Loc
,
2537 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
2538 Parameter_Associations
=> Actual_List
);
2546 -- Proc (New_Obj, ...);
2551 Make_Block_Statement
(Loc
,
2552 Declarations
=> New_List
(New_Obj
),
2553 Handled_Statement_Sequence
=>
2554 Make_Handled_Sequence_Of_Statements
(Loc
,
2555 Statements
=> New_List
(
2559 Make_Simple_Return_Statement
(Loc
,
2562 (Defining_Identifier
(New_Obj
), Loc
)))));
2564 Rewrite
(Ret_Stmt
, Blk_Stmt
);
2565 end Split_Unconstrained_Function
;
2569 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2571 -- Start of processing for Check_And_Split_Unconstrained_Function
2574 pragma Assert
(Back_End_Inlining
2575 and then Ekind
(Spec_Id
) = E_Function
2576 and then Returns_Unconstrained_Type
(Spec_Id
)
2577 and then Comes_From_Source
(Body_Id
)
2578 and then (Has_Pragma_Inline_Always
(Spec_Id
)
2579 or else Optimization_Level
> 0));
2581 -- This routine must not be used in GNATprove mode since GNATprove
2582 -- relies on frontend inlining
2584 pragma Assert
(not GNATprove_Mode
);
2586 -- No need to split the function if we cannot generate the code
2588 if Serious_Errors_Detected
/= 0 then
2592 -- No action needed in stubs since the attribute Body_To_Inline
2595 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
2598 -- Cannot build the body to inline if the attribute is already set.
2599 -- This attribute may have been set if this is a subprogram renaming
2600 -- declarations (see Freeze.Build_Renamed_Body).
2602 elsif Present
(Body_To_Inline
(Decl
)) then
2605 -- Do not generate a body to inline for protected functions, because the
2606 -- transformation generates a call to a protected procedure, causing
2607 -- spurious errors. We don't inline protected operations anyway, so
2608 -- this is no loss. We might as well ignore intrinsics and foreign
2609 -- conventions as well -- just allow Ada conventions.
2611 elsif not (Convention
(Spec_Id
) = Convention_Ada
2612 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Copy
2613 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Reference
)
2617 -- Check excluded declarations
2619 elsif Present
(Declarations
(N
))
2620 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
2624 -- Check excluded statements. There is no need to protect us against
2625 -- exception handlers since they are supported by the GCC backend.
2627 elsif Present
(Handled_Statement_Sequence
(N
))
2628 and then Has_Excluded_Statement
2629 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2634 -- Build the body to inline only if really needed
2636 if Can_Split_Unconstrained_Function
(N
) then
2637 Split_Unconstrained_Function
(N
, Spec_Id
);
2638 Build_Body_To_Inline
(N
, Spec_Id
);
2639 Set_Is_Inlined
(Spec_Id
);
2641 end Check_And_Split_Unconstrained_Function
;
2643 -------------------------------------
2644 -- Check_Package_Body_For_Inlining --
2645 -------------------------------------
2647 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2648 Bname
: Unit_Name_Type
;
2653 -- Legacy implementation (relying on frontend inlining)
2655 if not Back_End_Inlining
2656 and then Is_Compilation_Unit
(P
)
2657 and then not Is_Generic_Instance
(P
)
2659 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2661 E
:= First_Entity
(P
);
2662 while Present
(E
) loop
2663 if Has_Pragma_Inline_Always
(E
)
2664 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2666 if not Is_Loaded
(Bname
) then
2667 Load_Needed_Body
(N
, OK
);
2671 -- Check we are not trying to inline a parent whose body
2672 -- depends on a child, when we are compiling the body of
2673 -- the child. Otherwise we have a potential elaboration
2674 -- circularity with inlined subprograms and with
2675 -- Taft-Amendment types.
2678 Comp
: Node_Id
; -- Body just compiled
2679 Child_Spec
: Entity_Id
; -- Spec of main unit
2680 Ent
: Entity_Id
; -- For iteration
2681 With_Clause
: Node_Id
; -- Context of body.
2684 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2685 and then Present
(Body_Entity
(P
))
2689 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2692 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2694 -- Check whether the context of the body just
2695 -- compiled includes a child of itself, and that
2696 -- child is the spec of the main compilation.
2698 With_Clause
:= First
(Context_Items
(Comp
));
2699 while Present
(With_Clause
) loop
2700 if Nkind
(With_Clause
) = N_With_Clause
2702 Scope
(Entity
(Name
(With_Clause
))) = P
2704 Entity
(Name
(With_Clause
)) = Child_Spec
2706 Error_Msg_Node_2
:= Child_Spec
;
2708 ("body of & depends on child unit&??",
2711 ("\subprograms in body cannot be inlined??",
2714 -- Disable further inlining from this unit,
2715 -- and keep Taft-amendment types incomplete.
2717 Ent
:= First_Entity
(P
);
2718 while Present
(Ent
) loop
2720 and then Has_Completion_In_Body
(Ent
)
2722 Set_Full_View
(Ent
, Empty
);
2724 elsif Is_Subprogram
(Ent
) then
2725 Set_Is_Inlined
(Ent
, False);
2739 elsif Ineffective_Inline_Warnings
then
2740 Error_Msg_Unit_1
:= Bname
;
2742 ("unable to inline subprograms defined in $??", P
);
2743 Error_Msg_N
("\body not found??", P
);
2754 end Check_Package_Body_For_Inlining
;
2756 --------------------
2757 -- Cleanup_Scopes --
2758 --------------------
2760 procedure Cleanup_Scopes
is
2766 Elmt
:= First_Elmt
(To_Clean
);
2767 while Present
(Elmt
) loop
2768 Scop
:= Node
(Elmt
);
2770 if Ekind
(Scop
) = E_Entry
then
2771 Scop
:= Protected_Body_Subprogram
(Scop
);
2773 elsif Is_Subprogram
(Scop
)
2774 and then Is_Protected_Type
(Scope
(Scop
))
2775 and then Present
(Protected_Body_Subprogram
(Scop
))
2777 -- If a protected operation contains an instance, its cleanup
2778 -- operations have been delayed, and the subprogram has been
2779 -- rewritten in the expansion of the enclosing protected body. It
2780 -- is the corresponding subprogram that may require the cleanup
2781 -- operations, so propagate the information that triggers cleanup
2785 (Protected_Body_Subprogram
(Scop
),
2786 Uses_Sec_Stack
(Scop
));
2788 Scop
:= Protected_Body_Subprogram
(Scop
);
2791 if Ekind
(Scop
) = E_Block
then
2792 Decl
:= Parent
(Block_Node
(Scop
));
2795 Decl
:= Unit_Declaration_Node
(Scop
);
2797 if Nkind
(Decl
) in N_Subprogram_Declaration
2798 | N_Task_Type_Declaration
2799 | N_Subprogram_Body_Stub
2801 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2806 Expand_Cleanup_Actions
(Decl
);
2813 procedure Establish_Actual_Mapping_For_Inlined_Call
2817 Body_Or_Expr_To_Check
: Node_Id
)
2820 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2821 -- Determine whether a formal parameter is used only once in
2822 -- Body_Or_Expr_To_Check.
2824 -------------------------
2825 -- Formal_Is_Used_Once --
2826 -------------------------
2828 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
2829 Use_Counter
: Int
:= 0;
2831 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
2832 -- Traverse the tree and count the uses of the formal parameter.
2833 -- In this case, for optimization purposes, we do not need to
2834 -- continue the traversal once more than one use is encountered.
2840 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
2842 -- The original node is an identifier
2844 if Nkind
(N
) = N_Identifier
2845 and then Present
(Entity
(N
))
2847 -- Original node's entity points to the one in the copied body
2849 and then Nkind
(Entity
(N
)) = N_Identifier
2850 and then Present
(Entity
(Entity
(N
)))
2852 -- The entity of the copied node is the formal parameter
2854 and then Entity
(Entity
(N
)) = Formal
2856 Use_Counter
:= Use_Counter
+ 1;
2858 if Use_Counter
> 1 then
2860 -- Denote more than one use and abandon the traversal
2871 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
2873 -- Start of processing for Formal_Is_Used_Once
2876 Count_Formal_Uses
(Body_Or_Expr_To_Check
);
2877 return Use_Counter
= 1;
2878 end Formal_Is_Used_Once
;
2885 Loc
: constant Source_Ptr
:= Sloc
(N
);
2888 Temp_Typ
: Entity_Id
;
2890 -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
2893 F
:= First_Formal
(Subp
);
2894 A
:= First_Actual
(N
);
2895 while Present
(F
) loop
2896 if Present
(Renamed_Object
(F
)) then
2898 -- If expander is active, it is an error to try to inline a
2899 -- recursive program. In GNATprove mode, just indicate that the
2900 -- inlining will not happen, and mark the subprogram as not always
2903 if GNATprove_Mode
then
2905 ("cannot inline call to recursive subprogram?", N
, Subp
);
2906 Set_Is_Inlined_Always
(Subp
, False);
2909 ("cannot inline call to recursive subprogram", N
);
2915 -- Reset Last_Assignment for any parameters of mode out or in out, to
2916 -- prevent spurious warnings about overwriting for assignments to the
2917 -- formal in the inlined code.
2919 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
2921 -- In GNATprove mode a protected component acting as an actual
2922 -- subprogram parameter will appear as inlined-for-proof. However,
2923 -- its E_Component entity is not an assignable object, so the
2924 -- assertion in Set_Last_Assignment will fail. We just omit the
2925 -- call to Set_Last_Assignment, because GNATprove flags useless
2926 -- assignments with its own flow analysis.
2928 -- In GNAT mode such a problem does not occur, because protected
2929 -- components are inlined via object renamings whose entity kind
2930 -- E_Variable is assignable.
2932 if Is_Assignable
(Entity
(A
)) then
2933 Set_Last_Assignment
(Entity
(A
), Empty
);
2936 (GNATprove_Mode
and then Is_Protected_Component
(Entity
(A
)));
2940 -- If the argument may be a controlling argument in a call within
2941 -- the inlined body, we must preserve its class-wide nature to ensure
2942 -- that dynamic dispatching will take place subsequently. If the
2943 -- formal has a constraint, then it must be preserved to retain the
2944 -- semantics of the body.
2946 if Is_Class_Wide_Type
(Etype
(F
))
2947 or else (Is_Access_Type
(Etype
(F
))
2948 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
2950 Temp_Typ
:= Etype
(F
);
2952 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
2953 and then Etype
(F
) /= Base_Type
(Etype
(F
))
2954 and then Is_Constrained
(Etype
(F
))
2956 Temp_Typ
:= Etype
(F
);
2959 Temp_Typ
:= Etype
(A
);
2962 -- If the actual is a simple name or a literal, no need to
2963 -- create a temporary, object can be used directly.
2965 -- If the actual is a literal and the formal has its address taken,
2966 -- we cannot pass the literal itself as an argument, so its value
2967 -- must be captured in a temporary. Skip this optimization in
2968 -- GNATprove mode, to make sure any check on a type conversion
2971 if (Is_Entity_Name
(A
)
2973 (not Is_Scalar_Type
(Etype
(A
))
2974 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
)
2975 and then not GNATprove_Mode
)
2977 -- When the actual is an identifier and the corresponding formal is
2978 -- used only once in the original body, the formal can be substituted
2979 -- directly with the actual parameter. Skip this optimization in
2980 -- GNATprove mode, to make sure any check on a type conversion
2984 (Nkind
(A
) = N_Identifier
2985 and then Formal_Is_Used_Once
(F
)
2986 and then not GNATprove_Mode
)
2990 N_Real_Literal | N_Integer_Literal | N_Character_Literal
2991 and then not Address_Taken
(F
))
2993 if Etype
(F
) /= Etype
(A
) then
2995 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
2997 Set_Renamed_Object
(F
, A
);
3001 Temp
:= Make_Temporary
(Loc
, 'C');
3003 -- If the actual for an in/in-out parameter is a view conversion,
3004 -- make it into an unchecked conversion, given that an untagged
3005 -- type conversion is not a proper object for a renaming.
3007 -- In-out conversions that involve real conversions have already
3008 -- been transformed in Expand_Actuals.
3010 if Nkind
(A
) = N_Type_Conversion
3011 and then Ekind
(F
) /= E_In_Parameter
3014 Make_Unchecked_Type_Conversion
(Loc
,
3015 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3016 Expression
=> Relocate_Node
(Expression
(A
)));
3018 -- In GNATprove mode, keep the most precise type of the actual for
3019 -- the temporary variable, when the formal type is unconstrained.
3020 -- Otherwise, the AST may contain unexpected assignment statements
3021 -- to a temporary variable of unconstrained type renaming a local
3022 -- variable of constrained type, which is not expected by
3025 elsif Etype
(F
) /= Etype
(A
)
3026 and then (not GNATprove_Mode
or else Is_Constrained
(Etype
(F
)))
3028 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3029 Temp_Typ
:= Etype
(F
);
3032 New_A
:= Relocate_Node
(A
);
3035 Set_Sloc
(New_A
, Sloc
(N
));
3037 -- If the actual has a by-reference type, it cannot be copied,
3038 -- so its value is captured in a renaming declaration. Otherwise
3039 -- declare a local constant initialized with the actual.
3041 -- We also use a renaming declaration for expressions of an array
3042 -- type that is not bit-packed, both for efficiency reasons and to
3043 -- respect the semantics of the call: in most cases the original
3044 -- call will pass the parameter by reference, and thus the inlined
3045 -- code will have the same semantics.
3047 -- Finally, we need a renaming declaration in the case of limited
3048 -- types for which initialization cannot be by copy either.
3050 if Ekind
(F
) = E_In_Parameter
3051 and then not Is_By_Reference_Type
(Etype
(A
))
3052 and then not Is_Limited_Type
(Etype
(A
))
3054 (not Is_Array_Type
(Etype
(A
))
3055 or else not Is_Object_Reference
(A
)
3056 or else Is_Bit_Packed_Array
(Etype
(A
)))
3059 Make_Object_Declaration
(Loc
,
3060 Defining_Identifier
=> Temp
,
3061 Constant_Present
=> True,
3062 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3063 Expression
=> New_A
);
3066 -- In GNATprove mode, make an explicit copy of input
3067 -- parameters when formal and actual types differ, to make
3068 -- sure any check on the type conversion will be issued.
3069 -- The legality of the copy is ensured by calling first
3070 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3073 and then Ekind
(F
) /= E_Out_Parameter
3074 and then not Same_Type
(Etype
(F
), Etype
(A
))
3076 pragma Assert
(not Is_By_Reference_Type
(Etype
(A
)));
3077 pragma Assert
(not Is_Limited_Type
(Etype
(A
)));
3080 Make_Object_Declaration
(Loc
,
3081 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
3082 Constant_Present
=> True,
3083 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3084 Expression
=> New_Copy_Tree
(New_A
)));
3088 Make_Object_Renaming_Declaration
(Loc
,
3089 Defining_Identifier
=> Temp
,
3090 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3094 Append
(Decl
, Decls
);
3095 Set_Renamed_Object
(F
, Temp
);
3101 end Establish_Actual_Mapping_For_Inlined_Call
;
3103 -------------------------
3104 -- Expand_Inlined_Call --
3105 -------------------------
3107 procedure Expand_Inlined_Call
3110 Orig_Subp
: Entity_Id
)
3112 Decls
: constant List_Id
:= New_List
;
3113 Is_Predef
: constant Boolean :=
3114 Is_Predefined_Unit
(Get_Source_Unit
(Subp
));
3115 Loc
: constant Source_Ptr
:= Sloc
(N
);
3116 Orig_Bod
: constant Node_Id
:=
3117 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
3119 Uses_Back_End
: constant Boolean :=
3120 Back_End_Inlining
and then Optimization_Level
> 0;
3121 -- The back-end expansion is used if the target supports back-end
3122 -- inlining and some level of optimixation is required; otherwise
3123 -- the inlining takes place fully as a tree expansion.
3127 Exit_Lab
: Entity_Id
:= Empty
;
3128 Lab_Decl
: Node_Id
:= Empty
;
3131 Ret_Type
: Entity_Id
;
3135 Is_Unc_Decl
: Boolean;
3136 -- If the type returned by the function is unconstrained and the call
3137 -- can be inlined, special processing is required.
3139 Return_Object
: Entity_Id
:= Empty
;
3140 -- Entity in declaration in an extended_return_statement
3142 Targ
: Node_Id
:= Empty
;
3143 -- The target of the call. If context is an assignment statement then
3144 -- this is the left-hand side of the assignment, else it is a temporary
3145 -- to which the return value is assigned prior to rewriting the call.
3147 Targ1
: Node_Id
:= Empty
;
3148 -- A separate target used when the return type is unconstrained
3150 procedure Declare_Postconditions_Result
;
3151 -- When generating C code, declare _Result, which may be used in the
3152 -- inlined _Postconditions procedure to verify the return value.
3154 procedure Make_Exit_Label
;
3155 -- Build declaration for exit label to be used in Return statements,
3156 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
3157 -- declaration). Does nothing if Exit_Lab already set.
3159 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
);
3160 -- When compiling for CCG and performing front-end inlining, replace
3161 -- loop names and references to them so that they do not conflict with
3162 -- homographs in the current subprogram.
3164 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
3165 -- Replace occurrence of a formal with the corresponding actual, or the
3166 -- thunk generated for it. Replace a return statement with an assignment
3167 -- to the target of the call, with appropriate conversions if needed.
3169 function Process_Formals_In_Aspects
(N
: Node_Id
) return Traverse_Result
;
3170 -- Because aspects are linked indirectly to the rest of the tree,
3171 -- replacement of formals appearing in aspect specifications must
3172 -- be performed in a separate pass, using an instantiation of the
3173 -- previous subprogram over aspect specifications reachable from N.
3175 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
3176 -- If the call being expanded is that of an internal subprogram, set the
3177 -- sloc of the generated block to that of the call itself, so that the
3178 -- expansion is skipped by the "next" command in gdb. Same processing
3179 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
3180 -- Debug_Generated_Code is true, suppress this change to simplify our
3181 -- own development. Same in GNATprove mode, to ensure that warnings and
3182 -- diagnostics point to the proper location.
3184 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
3185 -- In subtree N search for occurrences of dispatching calls that use the
3186 -- Ada 2005 Object.Operation notation and the object is a formal of the
3187 -- inlined subprogram. Reset the entity associated with Operation in all
3188 -- the found occurrences.
3190 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
3191 -- If the function body is a single expression, replace call with
3192 -- expression, else insert block appropriately.
3194 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
3195 -- If procedure body has no local variables, inline body without
3196 -- creating block, otherwise rewrite call with block.
3198 -----------------------------------
3199 -- Declare_Postconditions_Result --
3200 -----------------------------------
3202 procedure Declare_Postconditions_Result
is
3203 Enclosing_Subp
: constant Entity_Id
:= Scope
(Subp
);
3208 and then Is_Subprogram
(Enclosing_Subp
)
3209 and then Present
(Postconditions_Proc
(Enclosing_Subp
)));
3211 if Ekind
(Enclosing_Subp
) = E_Function
then
3212 if Nkind
(First
(Parameter_Associations
(N
))) in
3213 N_Numeric_Or_String_Literal
3215 Append_To
(Declarations
(Blk
),
3216 Make_Object_Declaration
(Loc
,
3217 Defining_Identifier
=>
3218 Make_Defining_Identifier
(Loc
, Name_uResult
),
3219 Constant_Present
=> True,
3220 Object_Definition
=>
3221 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
3223 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
3225 Append_To
(Declarations
(Blk
),
3226 Make_Object_Renaming_Declaration
(Loc
,
3227 Defining_Identifier
=>
3228 Make_Defining_Identifier
(Loc
, Name_uResult
),
3230 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
3232 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
3235 end Declare_Postconditions_Result
;
3237 ---------------------
3238 -- Make_Exit_Label --
3239 ---------------------
3241 procedure Make_Exit_Label
is
3242 Lab_Ent
: Entity_Id
;
3244 if No
(Exit_Lab
) then
3245 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
3246 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
3247 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
3249 Make_Implicit_Label_Declaration
(Loc
,
3250 Defining_Identifier
=> Lab_Ent
,
3251 Label_Construct
=> Exit_Lab
);
3253 end Make_Exit_Label
;
3255 -----------------------------
3256 -- Make_Loop_Labels_Unique --
3257 -----------------------------
3259 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
) is
3260 function Process_Loop
(N
: Node_Id
) return Traverse_Result
;
3266 function Process_Loop
(N
: Node_Id
) return Traverse_Result
is
3270 if Nkind
(N
) = N_Loop_Statement
3271 and then Present
(Identifier
(N
))
3273 -- Create new external name for loop and update the
3274 -- corresponding entity.
3276 Id
:= Entity
(Identifier
(N
));
3277 Set_Chars
(Id
, New_External_Name
(Chars
(Id
), 'L', -1));
3278 Set_Chars
(Identifier
(N
), Chars
(Id
));
3280 elsif Nkind
(N
) = N_Exit_Statement
3281 and then Present
(Name
(N
))
3283 -- The exit statement must name an enclosing loop, whose name
3284 -- has already been updated.
3286 Set_Chars
(Name
(N
), Chars
(Entity
(Name
(N
))));
3292 procedure Update_Loop_Names
is new Traverse_Proc
(Process_Loop
);
3298 -- Start of processing for Make_Loop_Labels_Unique
3301 if Modify_Tree_For_C
then
3302 Stmt
:= First
(Statements
(HSS
));
3303 while Present
(Stmt
) loop
3304 Update_Loop_Names
(Stmt
);
3308 end Make_Loop_Labels_Unique
;
3310 ---------------------
3311 -- Process_Formals --
3312 ---------------------
3314 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3320 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3323 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
3324 A
:= Renamed_Object
(E
);
3326 -- Rewrite the occurrence of the formal into an occurrence of
3327 -- the actual. Also establish visibility on the proper view of
3328 -- the actual's subtype for the body's context (if the actual's
3329 -- subtype is private at the call point but its full view is
3330 -- visible to the body, then the inlined tree here must be
3331 -- analyzed with the full view).
3333 if Is_Entity_Name
(A
) then
3334 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
3335 Check_Private_View
(N
);
3337 elsif Nkind
(A
) = N_Defining_Identifier
then
3338 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
3339 Check_Private_View
(N
);
3344 Rewrite
(N
, New_Copy
(A
));
3350 elsif Is_Entity_Name
(N
)
3351 and then Present
(Return_Object
)
3352 and then Chars
(N
) = Chars
(Return_Object
)
3354 -- Occurrence within an extended return statement. The return
3355 -- object is local to the body been inlined, and thus the generic
3356 -- copy is not analyzed yet, so we match by name, and replace it
3357 -- with target of call.
3359 if Nkind
(Targ
) = N_Defining_Identifier
then
3360 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
3362 Rewrite
(N
, New_Copy_Tree
(Targ
));
3367 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3368 if No
(Expression
(N
)) then
3369 Num_Ret
:= Num_Ret
+ 1;
3372 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3375 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3376 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3378 -- Function body is a single expression. No need for
3384 Num_Ret
:= Num_Ret
+ 1;
3388 -- Because of the presence of private types, the views of the
3389 -- expression and the context may be different, so place
3390 -- a type conversion to the context type to avoid spurious
3391 -- errors, e.g. when the expression is a numeric literal and
3392 -- the context is private. If the expression is an aggregate,
3393 -- use a qualified expression, because an aggregate is not a
3394 -- legal argument of a conversion. Ditto for numeric, character
3395 -- and string literals, and attributes that yield a universal
3396 -- type, because those must be resolved to a specific type.
3398 if Nkind
(Expression
(N
)) in N_Aggregate
3399 | N_Character_Literal
3402 or else Yields_Universal_Type
(Expression
(N
))
3405 Make_Qualified_Expression
(Sloc
(N
),
3406 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3407 Expression
=> Relocate_Node
(Expression
(N
)));
3409 -- Use an unchecked type conversion between access types, for
3410 -- which a type conversion would not always be valid, as no
3411 -- check may result from the conversion.
3413 elsif Is_Access_Type
(Ret_Type
) then
3415 Unchecked_Convert_To
3416 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3418 -- Otherwise use a type conversion, which may trigger a check
3422 Make_Type_Conversion
(Sloc
(N
),
3423 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3424 Expression
=> Relocate_Node
(Expression
(N
)));
3427 if Nkind
(Targ
) = N_Defining_Identifier
then
3429 Make_Assignment_Statement
(Loc
,
3430 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3431 Expression
=> Ret
));
3434 Make_Assignment_Statement
(Loc
,
3435 Name
=> New_Copy
(Targ
),
3436 Expression
=> Ret
));
3439 Set_Assignment_OK
(Name
(N
));
3441 if Present
(Exit_Lab
) then
3443 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3449 -- An extended return becomes a block whose first statement is the
3450 -- assignment of the initial expression of the return object to the
3451 -- target of the call itself.
3453 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3455 Return_Decl
: constant Entity_Id
:=
3456 First
(Return_Object_Declarations
(N
));
3460 Return_Object
:= Defining_Identifier
(Return_Decl
);
3462 if Present
(Expression
(Return_Decl
)) then
3463 if Nkind
(Targ
) = N_Defining_Identifier
then
3465 Make_Assignment_Statement
(Loc
,
3466 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3467 Expression
=> Expression
(Return_Decl
));
3470 Make_Assignment_Statement
(Loc
,
3471 Name
=> New_Copy
(Targ
),
3472 Expression
=> Expression
(Return_Decl
));
3475 Set_Assignment_OK
(Name
(Assign
));
3477 if No
(Handled_Statement_Sequence
(N
)) then
3478 Set_Handled_Statement_Sequence
(N
,
3479 Make_Handled_Sequence_Of_Statements
(Loc
,
3480 Statements
=> New_List
));
3484 Statements
(Handled_Statement_Sequence
(N
)));
3488 Make_Block_Statement
(Loc
,
3489 Handled_Statement_Sequence
=>
3490 Handled_Statement_Sequence
(N
)));
3495 -- Remove pragma Unreferenced since it may refer to formals that
3496 -- are not visible in the inlined body, and in any case we will
3497 -- not be posting warnings on the inlined body so it is unneeded.
3499 elsif Nkind
(N
) = N_Pragma
3500 and then Pragma_Name
(N
) = Name_Unreferenced
3502 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3508 end Process_Formals
;
3510 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3512 --------------------------------
3513 -- Process_Formals_In_Aspects --
3514 --------------------------------
3516 function Process_Formals_In_Aspects
3517 (N
: Node_Id
) return Traverse_Result
3522 if Has_Aspects
(N
) then
3523 A
:= First
(Aspect_Specifications
(N
));
3524 while Present
(A
) loop
3525 Replace_Formals
(Expression
(A
));
3531 end Process_Formals_In_Aspects
;
3533 procedure Replace_Formals_In_Aspects
is
3534 new Traverse_Proc
(Process_Formals_In_Aspects
);
3540 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3542 if not Debug_Generated_Code
then
3543 Set_Sloc
(Nod
, Sloc
(N
));
3544 Set_Comes_From_Source
(Nod
, False);
3550 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3552 ------------------------------
3553 -- Reset_Dispatching_Calls --
3554 ------------------------------
3556 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
3558 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
3559 -- Comment required ???
3565 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
3567 if Nkind
(N
) = N_Procedure_Call_Statement
3568 and then Nkind
(Name
(N
)) = N_Selected_Component
3569 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
3570 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
3571 and then Is_Dispatching_Operation
3572 (Entity
(Selector_Name
(Name
(N
))))
3574 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
3580 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
3584 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
3585 pragma Unreferenced
(Dummy
);
3587 -- Start of processing for Reset_Dispatching_Calls
3591 end Reset_Dispatching_Calls
;
3593 ---------------------------
3594 -- Rewrite_Function_Call --
3595 ---------------------------
3597 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3598 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3599 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3602 Make_Loop_Labels_Unique
(HSS
);
3604 -- Optimize simple case: function body is a single return statement,
3605 -- which has been expanded into an assignment.
3607 if Is_Empty_List
(Declarations
(Blk
))
3608 and then Nkind
(Fst
) = N_Assignment_Statement
3609 and then No
(Next
(Fst
))
3611 -- The function call may have been rewritten as the temporary
3612 -- that holds the result of the call, in which case remove the
3613 -- now useless declaration.
3615 if Nkind
(N
) = N_Identifier
3616 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3618 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3621 Rewrite
(N
, Expression
(Fst
));
3623 elsif Nkind
(N
) = N_Identifier
3624 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3626 -- The block assigns the result of the call to the temporary
3628 Insert_After
(Parent
(Entity
(N
)), Blk
);
3630 -- If the context is an assignment, and the left-hand side is free of
3631 -- side-effects, the replacement is also safe.
3632 -- Can this be generalized further???
3634 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3636 (Is_Entity_Name
(Name
(Parent
(N
)))
3638 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3639 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
3642 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3643 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3645 -- Replace assignment with the block
3648 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3651 -- Preserve the original assignment node to keep the complete
3652 -- assignment subtree consistent enough for Analyze_Assignment
3653 -- to proceed (specifically, the original Lhs node must still
3654 -- have an assignment statement as its parent).
3656 -- We cannot rely on Original_Node to go back from the block
3657 -- node to the assignment node, because the assignment might
3658 -- already be a rewrite substitution.
3660 Discard_Node
(Relocate_Node
(Original_Assignment
));
3661 Rewrite
(Original_Assignment
, Blk
);
3664 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3666 -- A call to a function which returns an unconstrained type
3667 -- found in the expression initializing an object-declaration is
3668 -- expanded into a procedure call which must be added after the
3669 -- object declaration.
3671 if Is_Unc_Decl
and Back_End_Inlining
then
3672 Insert_Action_After
(Parent
(N
), Blk
);
3674 Set_Expression
(Parent
(N
), Empty
);
3675 Insert_After
(Parent
(N
), Blk
);
3678 elsif Is_Unc
and then not Back_End_Inlining
then
3679 Insert_Before
(Parent
(N
), Blk
);
3681 end Rewrite_Function_Call
;
3683 ----------------------------
3684 -- Rewrite_Procedure_Call --
3685 ----------------------------
3687 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3688 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3691 Make_Loop_Labels_Unique
(HSS
);
3693 -- If there is a transient scope for N, this will be the scope of the
3694 -- actions for N, and the statements in Blk need to be within this
3695 -- scope. For example, they need to have visibility on the constant
3696 -- declarations created for the formals.
3698 -- If N needs no transient scope, and if there are no declarations in
3699 -- the inlined body, we can do a little optimization and insert the
3700 -- statements for the body directly after N, and rewrite N to a
3701 -- null statement, instead of rewriting N into a full-blown block
3704 if not Scope_Is_Transient
3705 and then Is_Empty_List
(Declarations
(Blk
))
3707 Insert_List_After
(N
, Statements
(HSS
));
3708 Rewrite
(N
, Make_Null_Statement
(Loc
));
3712 end Rewrite_Procedure_Call
;
3714 -- Start of processing for Expand_Inlined_Call
3717 -- Initializations for old/new semantics
3719 if not Uses_Back_End
then
3720 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
3721 and then not Is_Constrained
(Etype
(Subp
));
3722 Is_Unc_Decl
:= False;
3724 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
3725 and then Optimization_Level
> 0;
3726 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
3730 -- Check for an illegal attempt to inline a recursive procedure. If the
3731 -- subprogram has parameters this is detected when trying to supply a
3732 -- binding for parameters that already have one. For parameterless
3733 -- subprograms this must be done explicitly.
3735 if In_Open_Scopes
(Subp
) then
3737 ("cannot inline call to recursive subprogram?", N
, Subp
);
3738 Set_Is_Inlined
(Subp
, False);
3741 -- Skip inlining if this is not a true inlining since the attribute
3742 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3743 -- true inlining, Orig_Bod has code rather than being an entity.
3745 elsif Nkind
(Orig_Bod
) in N_Entity
then
3749 if Nkind
(Orig_Bod
) in N_Defining_Identifier
3750 | N_Defining_Operator_Symbol
3752 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3753 -- can be replaced with calls to the renamed entity directly, because
3754 -- the subprograms are subtype conformant. If the renamed subprogram
3755 -- is an inherited operation, we must redo the expansion because
3756 -- implicit conversions may be needed. Similarly, if the renamed
3757 -- entity is inlined, expand the call for further optimizations.
3759 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3761 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
3768 -- Register the call in the list of inlined calls
3770 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
3772 -- Use generic machinery to copy body of inlined subprogram, as if it
3773 -- were an instantiation, resetting source locations appropriately, so
3774 -- that nested inlined calls appear in the main unit.
3776 Save_Env
(Subp
, Empty
);
3777 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3781 if not Uses_Back_End
then
3786 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3788 Make_Block_Statement
(Loc
,
3789 Declarations
=> Declarations
(Bod
),
3790 Handled_Statement_Sequence
=>
3791 Handled_Statement_Sequence
(Bod
));
3793 if No
(Declarations
(Bod
)) then
3794 Set_Declarations
(Blk
, New_List
);
3797 -- When generating C code, declare _Result, which may be used to
3798 -- verify the return value.
3800 if Modify_Tree_For_C
3801 and then Nkind
(N
) = N_Procedure_Call_Statement
3802 and then Chars
(Name
(N
)) = Name_uPostconditions
3804 Declare_Postconditions_Result
;
3807 -- For the unconstrained case, capture the name of the local
3808 -- variable that holds the result. This must be the first
3809 -- declaration in the block, because its bounds cannot depend
3810 -- on local variables. Otherwise there is no way to declare the
3811 -- result outside of the block. Needless to say, in general the
3812 -- bounds will depend on the actuals in the call.
3814 -- If the context is an assignment statement, as is the case
3815 -- for the expansion of an extended return, the left-hand side
3816 -- provides bounds even if the return type is unconstrained.
3820 First_Decl
: Node_Id
;
3823 First_Decl
:= First
(Declarations
(Blk
));
3825 -- If the body is a single extended return statement,the
3826 -- resulting block is a nested block.
3828 if No
(First_Decl
) then
3830 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3832 if Nkind
(First_Decl
) = N_Block_Statement
then
3833 First_Decl
:= First
(Declarations
(First_Decl
));
3837 -- No front-end inlining possible
3839 if Nkind
(First_Decl
) /= N_Object_Declaration
then
3843 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
3844 Targ1
:= Defining_Identifier
(First_Decl
);
3846 Targ1
:= Name
(Parent
(N
));
3863 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3865 Make_Block_Statement
(Loc
,
3866 Declarations
=> Declarations
(Bod
),
3867 Handled_Statement_Sequence
=>
3868 Handled_Statement_Sequence
(Bod
));
3870 -- Inline a call to a function that returns an unconstrained type.
3871 -- The semantic analyzer checked that frontend-inlined functions
3872 -- returning unconstrained types have no declarations and have
3873 -- a single extended return statement. As part of its processing
3874 -- the function was split into two subprograms: a procedure P' and
3875 -- a function F' that has a block with a call to procedure P' (see
3876 -- Split_Unconstrained_Function).
3882 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
3886 Blk_Stmt
: constant Node_Id
:=
3887 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
3888 First_Stmt
: constant Node_Id
:=
3889 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
3890 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
3894 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
3895 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
3896 and then No
(Next
(Second_Stmt
)));
3901 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
3902 Empty
, Instantiating
=> True);
3905 -- Capture the name of the local variable that holds the
3906 -- result. This must be the first declaration in the block,
3907 -- because its bounds cannot depend on local variables.
3908 -- Otherwise there is no way to declare the result outside
3909 -- of the block. Needless to say, in general the bounds will
3910 -- depend on the actuals in the call.
3912 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
3913 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3915 -- If the context is an assignment statement, as is the case
3916 -- for the expansion of an extended return, the left-hand
3917 -- side provides bounds even if the return type is
3921 Targ1
:= Name
(Parent
(N
));
3926 if No
(Declarations
(Bod
)) then
3927 Set_Declarations
(Blk
, New_List
);
3932 -- If this is a derived function, establish the proper return type
3934 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
3935 Ret_Type
:= Etype
(Orig_Subp
);
3937 Ret_Type
:= Etype
(Subp
);
3940 -- Create temporaries for the actuals that are expressions, or that are
3941 -- scalars and require copying to preserve semantics.
3943 Establish_Actual_Mapping_For_Inlined_Call
(N
, Subp
, Decls
, Orig_Bod
);
3945 -- Establish target of function call. If context is not assignment or
3946 -- declaration, create a temporary as a target. The declaration for the
3947 -- temporary may be subsequently optimized away if the body is a single
3948 -- expression, or if the left-hand side of the assignment is simple
3949 -- enough, i.e. an entity or an explicit dereference of one.
3951 if Ekind
(Subp
) = E_Function
then
3952 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3953 and then Is_Entity_Name
(Name
(Parent
(N
)))
3955 Targ
:= Name
(Parent
(N
));
3957 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3958 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3959 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3961 Targ
:= Name
(Parent
(N
));
3963 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3964 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3965 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3967 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3969 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3970 and then Is_Limited_Type
(Etype
(Subp
))
3972 Targ
:= Defining_Identifier
(Parent
(N
));
3974 -- New semantics: In an object declaration avoid an extra copy
3975 -- of the result of a call to an inlined function that returns
3976 -- an unconstrained type
3979 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3982 Targ
:= Defining_Identifier
(Parent
(N
));
3985 -- Replace call with temporary and create its declaration
3987 Temp
:= Make_Temporary
(Loc
, 'C');
3988 Set_Is_Internal
(Temp
);
3990 -- For the unconstrained case, the generated temporary has the
3991 -- same constrained declaration as the result variable. It may
3992 -- eventually be possible to remove that temporary and use the
3993 -- result variable directly.
3995 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3998 Make_Object_Declaration
(Loc
,
3999 Defining_Identifier
=> Temp
,
4000 Object_Definition
=>
4001 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
4003 Replace_Formals
(Decl
);
4007 Make_Object_Declaration
(Loc
,
4008 Defining_Identifier
=> Temp
,
4009 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
4011 Set_Etype
(Temp
, Ret_Type
);
4014 Set_No_Initialization
(Decl
);
4015 Append
(Decl
, Decls
);
4016 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
4021 Insert_Actions
(N
, Decls
);
4025 -- Special management for inlining a call to a function that returns
4026 -- an unconstrained type and initializes an object declaration: we
4027 -- avoid generating undesired extra calls and goto statements.
4030 -- function Func (...) return String is
4033 -- Result : String (1 .. 4);
4035 -- Proc (Result, ...);
4040 -- Result : String := Func (...);
4042 -- Replace this object declaration by:
4044 -- Result : String (1 .. 4);
4045 -- Proc (Result, ...);
4047 Remove_Homonym
(Targ
);
4050 Make_Object_Declaration
4052 Defining_Identifier
=> Targ
,
4053 Object_Definition
=>
4054 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
4055 Replace_Formals
(Decl
);
4056 Rewrite
(Parent
(N
), Decl
);
4057 Analyze
(Parent
(N
));
4059 -- Avoid spurious warnings since we know that this declaration is
4060 -- referenced by the procedure call.
4062 Set_Never_Set_In_Source
(Targ
, False);
4064 -- Remove the local declaration of the extended return stmt from the
4067 Remove
(Parent
(Targ1
));
4069 -- Update the reference to the result (since we have rewriten the
4070 -- object declaration)
4073 Blk_Call_Stmt
: Node_Id
;
4076 -- Capture the call to the procedure
4079 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
4081 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
4083 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
4084 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
4085 New_Occurrence_Of
(Targ
, Loc
));
4088 -- Remove the return statement
4091 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4092 N_Simple_Return_Statement
);
4094 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4097 -- Traverse the tree and replace formals with actuals or their thunks.
4098 -- Attach block to tree before analysis and rewriting.
4100 Replace_Formals
(Blk
);
4101 Replace_Formals_In_Aspects
(Blk
);
4102 Set_Parent
(Blk
, N
);
4104 if GNATprove_Mode
then
4107 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
4113 -- No action needed since return statement has been already removed
4117 elsif Present
(Exit_Lab
) then
4119 -- If there's a single return statement at the end of the subprogram,
4120 -- the corresponding goto statement and the corresponding label are
4125 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4128 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4130 Append
(Lab_Decl
, (Declarations
(Blk
)));
4131 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
4135 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
4136 -- on conflicting private views that Gigi would ignore. If this is a
4137 -- predefined unit, analyze with checks off, as is done in the non-
4138 -- inlined run-time units.
4141 I_Flag
: constant Boolean := In_Inlined_Body
;
4144 In_Inlined_Body
:= True;
4148 Style
: constant Boolean := Style_Check
;
4151 Style_Check
:= False;
4153 -- Search for dispatching calls that use the Object.Operation
4154 -- notation using an Object that is a parameter of the inlined
4155 -- function. We reset the decoration of Operation to force
4156 -- the reanalysis of the inlined dispatching call because
4157 -- the actual object has been inlined.
4159 Reset_Dispatching_Calls
(Blk
);
4161 -- In GNATprove mode, always consider checks on, even for
4162 -- predefined units.
4164 if GNATprove_Mode
then
4167 Analyze
(Blk
, Suppress
=> All_Checks
);
4170 Style_Check
:= Style
;
4177 In_Inlined_Body
:= I_Flag
;
4180 if Ekind
(Subp
) = E_Procedure
then
4181 Rewrite_Procedure_Call
(N
, Blk
);
4184 Rewrite_Function_Call
(N
, Blk
);
4189 -- For the unconstrained case, the replacement of the call has been
4190 -- made prior to the complete analysis of the generated declarations.
4191 -- Propagate the proper type now.
4194 if Nkind
(N
) = N_Identifier
then
4195 Set_Etype
(N
, Etype
(Entity
(N
)));
4197 Set_Etype
(N
, Etype
(Targ1
));
4204 -- Cleanup mapping between formals and actuals for other expansions
4206 Reset_Actual_Mapping_For_Inlined_Call
(Subp
);
4207 end Expand_Inlined_Call
;
4209 --------------------------
4210 -- Get_Code_Unit_Entity --
4211 --------------------------
4213 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
4214 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
4217 if Ekind
(Unit
) = E_Package_Body
then
4218 Unit
:= Spec_Entity
(Unit
);
4222 end Get_Code_Unit_Entity
;
4224 ------------------------------
4225 -- Has_Excluded_Declaration --
4226 ------------------------------
4228 function Has_Excluded_Declaration
4230 Decls
: List_Id
) return Boolean
4234 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
4235 -- Nested subprograms make a given body ineligible for inlining, but
4236 -- we make an exception for instantiations of unchecked conversion.
4237 -- The body has not been analyzed yet, so check the name, and verify
4238 -- that the visible entity with that name is the predefined unit.
4240 -----------------------------
4241 -- Is_Unchecked_Conversion --
4242 -----------------------------
4244 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
4245 Id
: constant Node_Id
:= Name
(D
);
4249 if Nkind
(Id
) = N_Identifier
4250 and then Chars
(Id
) = Name_Unchecked_Conversion
4252 Conv
:= Current_Entity
(Id
);
4254 elsif Nkind
(Id
) in N_Selected_Component | N_Expanded_Name
4255 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
4257 Conv
:= Current_Entity
(Selector_Name
(Id
));
4262 return Present
(Conv
)
4263 and then Is_Predefined_Unit
(Get_Source_Unit
(Conv
))
4264 and then Is_Intrinsic_Subprogram
(Conv
);
4265 end Is_Unchecked_Conversion
;
4267 -- Start of processing for Has_Excluded_Declaration
4270 -- No action needed if the check is not needed
4272 if not Check_Inlining_Restrictions
then
4277 while Present
(D
) loop
4279 -- First declarations universally excluded
4281 if Nkind
(D
) = N_Package_Declaration
then
4283 ("cannot inline & (nested package declaration)?", D
, Subp
);
4286 elsif Nkind
(D
) = N_Package_Instantiation
then
4288 ("cannot inline & (nested package instantiation)?", D
, Subp
);
4292 -- Then declarations excluded only for front-end inlining
4294 if Back_End_Inlining
then
4297 elsif Nkind
(D
) = N_Task_Type_Declaration
4298 or else Nkind
(D
) = N_Single_Task_Declaration
4301 ("cannot inline & (nested task type declaration)?", D
, Subp
);
4304 elsif Nkind
(D
) = N_Protected_Type_Declaration
4305 or else Nkind
(D
) = N_Single_Protected_Declaration
4308 ("cannot inline & (nested protected type declaration)?",
4312 elsif Nkind
(D
) = N_Subprogram_Body
then
4314 ("cannot inline & (nested subprogram)?", D
, Subp
);
4317 elsif Nkind
(D
) = N_Function_Instantiation
4318 and then not Is_Unchecked_Conversion
(D
)
4321 ("cannot inline & (nested function instantiation)?", D
, Subp
);
4324 elsif Nkind
(D
) = N_Procedure_Instantiation
then
4326 ("cannot inline & (nested procedure instantiation)?", D
, Subp
);
4329 -- Subtype declarations with predicates will generate predicate
4330 -- functions, i.e. nested subprogram bodies, so inlining is not
4333 elsif Nkind
(D
) = N_Subtype_Declaration
4334 and then Present
(Aspect_Specifications
(D
))
4341 A
:= First
(Aspect_Specifications
(D
));
4342 while Present
(A
) loop
4343 A_Id
:= Get_Aspect_Id
(Chars
(Identifier
(A
)));
4345 if A_Id
= Aspect_Predicate
4346 or else A_Id
= Aspect_Static_Predicate
4347 or else A_Id
= Aspect_Dynamic_Predicate
4350 ("cannot inline & (subtype declaration with "
4351 & "predicate)?", D
, Subp
);
4364 end Has_Excluded_Declaration
;
4366 ----------------------------
4367 -- Has_Excluded_Statement --
4368 ----------------------------
4370 function Has_Excluded_Statement
4372 Stats
: List_Id
) return Boolean
4378 -- No action needed if the check is not needed
4380 if not Check_Inlining_Restrictions
then
4385 while Present
(S
) loop
4386 if Nkind
(S
) in N_Abort_Statement
4387 | N_Asynchronous_Select
4388 | N_Conditional_Entry_Call
4389 | N_Delay_Relative_Statement
4390 | N_Delay_Until_Statement
4391 | N_Selective_Accept
4392 | N_Timed_Entry_Call
4395 ("cannot inline & (non-allowed statement)?", S
, Subp
);
4398 elsif Nkind
(S
) = N_Block_Statement
then
4399 if Present
(Declarations
(S
))
4400 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
4404 elsif Present
(Handled_Statement_Sequence
(S
)) then
4405 if not Back_End_Inlining
4408 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
4411 ("cannot inline& (exception handler)?",
4412 First
(Exception_Handlers
4413 (Handled_Statement_Sequence
(S
))),
4417 elsif Has_Excluded_Statement
4418 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4424 elsif Nkind
(S
) = N_Case_Statement
then
4425 E
:= First
(Alternatives
(S
));
4426 while Present
(E
) loop
4427 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
4434 elsif Nkind
(S
) = N_If_Statement
then
4435 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
4439 if Present
(Elsif_Parts
(S
)) then
4440 E
:= First
(Elsif_Parts
(S
));
4441 while Present
(E
) loop
4442 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
4450 if Present
(Else_Statements
(S
))
4451 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
4456 elsif Nkind
(S
) = N_Loop_Statement
4457 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
4461 elsif Nkind
(S
) = N_Extended_Return_Statement
then
4462 if Present
(Handled_Statement_Sequence
(S
))
4464 Has_Excluded_Statement
4465 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4469 elsif not Back_End_Inlining
4470 and then Present
(Handled_Statement_Sequence
(S
))
4472 Present
(Exception_Handlers
4473 (Handled_Statement_Sequence
(S
)))
4476 ("cannot inline& (exception handler)?",
4477 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
4487 end Has_Excluded_Statement
;
4489 --------------------------
4490 -- Has_Initialized_Type --
4491 --------------------------
4493 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
4494 E_Body
: constant Node_Id
:= Subprogram_Body
(E
);
4498 if No
(E_Body
) then -- imported subprogram
4502 Decl
:= First
(Declarations
(E_Body
));
4503 while Present
(Decl
) loop
4504 if Nkind
(Decl
) = N_Full_Type_Declaration
4505 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
4515 end Has_Initialized_Type
;
4517 -----------------------
4518 -- Has_Single_Return --
4519 -----------------------
4521 function Has_Single_Return
(N
: Node_Id
) return Boolean is
4522 Return_Statement
: Node_Id
:= Empty
;
4524 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
4530 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
4532 if Nkind
(N
) = N_Simple_Return_Statement
then
4533 if Present
(Expression
(N
))
4534 and then Is_Entity_Name
(Expression
(N
))
4536 pragma Assert
(Present
(Entity
(Expression
(N
))));
4538 if No
(Return_Statement
) then
4539 Return_Statement
:= N
;
4544 (Present
(Entity
(Expression
(Return_Statement
))));
4546 if Entity
(Expression
(N
)) =
4547 Entity
(Expression
(Return_Statement
))
4555 -- A return statement within an extended return is a noop after
4558 elsif No
(Expression
(N
))
4559 and then Nkind
(Parent
(Parent
(N
))) =
4560 N_Extended_Return_Statement
4565 -- Expression has wrong form
4570 -- We can only inline a build-in-place function if it has a single
4573 elsif Nkind
(N
) = N_Extended_Return_Statement
then
4574 if No
(Return_Statement
) then
4575 Return_Statement
:= N
;
4587 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
4589 -- Start of processing for Has_Single_Return
4592 if Check_All_Returns
(N
) /= OK
then
4595 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
4600 Present
(Declarations
(N
))
4601 and then Present
(First
(Declarations
(N
)))
4602 and then Entity
(Expression
(Return_Statement
)) =
4603 Defining_Identifier
(First
(Declarations
(N
)));
4605 end Has_Single_Return
;
4607 -----------------------------
4608 -- In_Main_Unit_Or_Subunit --
4609 -----------------------------
4611 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
4612 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
4615 -- Check whether the subprogram or package to inline is within the main
4616 -- unit or its spec or within a subunit. In either case there are no
4617 -- additional bodies to process. If the subprogram appears in a parent
4618 -- of the current unit, the check on whether inlining is possible is
4619 -- done in Analyze_Inlined_Bodies.
4621 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
4622 Comp
:= Library_Unit
(Comp
);
4625 return Comp
= Cunit
(Main_Unit
)
4626 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
4627 end In_Main_Unit_Or_Subunit
;
4633 procedure Initialize
is
4635 Pending_Instantiations
.Init
;
4636 Called_Pending_Instantiations
.Init
;
4637 Inlined_Bodies
.Init
;
4641 for J
in Hash_Headers
'Range loop
4642 Hash_Headers
(J
) := No_Subp
;
4645 Inlined_Calls
:= No_Elist
;
4646 Backend_Calls
:= No_Elist
;
4647 Backend_Instances
:= No_Elist
;
4648 Backend_Inlined_Subps
:= No_Elist
;
4649 Backend_Not_Inlined_Subps
:= No_Elist
;
4652 ---------------------------------
4653 -- Inline_Static_Function_Call --
4654 ---------------------------------
4656 procedure Inline_Static_Function_Call
(N
: Node_Id
; Subp
: Entity_Id
) is
4658 function Replace_Formal
(N
: Node_Id
) return Traverse_Result
;
4659 -- Replace each occurrence of a formal with the corresponding actual,
4660 -- using the mapping created by Establish_Mapping_For_Inlined_Call.
4662 function Reset_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
4663 -- Reset the Sloc of a node to that of the call itself, so that errors
4664 -- will be flagged on the call to the static expression function itself
4665 -- rather than on the expression of the function's declaration.
4667 --------------------
4668 -- Replace_Formal --
4669 --------------------
4671 function Replace_Formal
(N
: Node_Id
) return Traverse_Result
is
4676 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
4679 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
4680 A
:= Renamed_Object
(E
);
4682 if Nkind
(A
) = N_Defining_Identifier
then
4683 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
4688 Rewrite
(N
, New_Copy
(A
));
4699 procedure Replace_Formals
is new Traverse_Proc
(Replace_Formal
);
4705 function Reset_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
4707 Set_Sloc
(Nod
, Sloc
(N
));
4708 Set_Comes_From_Source
(Nod
, False);
4713 procedure Reset_Slocs
is new Traverse_Proc
(Reset_Sloc
);
4715 -- Start of processing for Inline_Static_Function_Call
4718 pragma Assert
(Is_Static_Function_Call
(N
));
4721 Decls
: constant List_Id
:= New_List
;
4722 Func_Expr
: constant Node_Id
:=
4723 Expression_Of_Expression_Function
(Subp
);
4724 Expr_Copy
: constant Node_Id
:= New_Copy_Tree
(Func_Expr
);
4727 -- Create a mapping from formals to actuals, also creating temps in
4728 -- Decls, when needed, to hold the actuals.
4730 Establish_Actual_Mapping_For_Inlined_Call
(N
, Subp
, Decls
, Func_Expr
);
4732 -- Ensure that the copy has the same parent as the call (this seems
4733 -- to matter when GNATprove_Mode is set and there are nested static
4734 -- calls; prevents blowups in Insert_Actions, though it's not clear
4735 -- exactly why this is needed???).
4737 Set_Parent
(Expr_Copy
, Parent
(N
));
4739 Insert_Actions
(N
, Decls
);
4741 -- Now substitute actuals for their corresponding formal references
4742 -- within the expression.
4744 Replace_Formals
(Expr_Copy
);
4746 Reset_Slocs
(Expr_Copy
);
4748 -- Apply a qualified expression with the function's result subtype,
4749 -- to ensure that we check the expression against any constraint
4750 -- or predicate, which will cause the call to be illegal if the
4751 -- folded expression doesn't satisfy them. (The predicate case
4752 -- might not get checked if the subtype hasn't been frozen yet,
4753 -- which can happen if this static expression happens to be what
4754 -- causes the freezing, because Has_Static_Predicate doesn't get
4755 -- set on the subtype until it's frozen and Build_Predicates is
4756 -- called. It's not clear how to address this case. ???)
4759 Make_Qualified_Expression
(Sloc
(Expr_Copy
),
4761 New_Occurrence_Of
(Etype
(N
), Sloc
(Expr_Copy
)),
4763 Relocate_Node
(Expr_Copy
)));
4765 Set_Etype
(Expr_Copy
, Etype
(N
));
4767 Analyze_And_Resolve
(Expr_Copy
, Etype
(N
));
4769 -- Finally rewrite the function call as the folded static result
4771 Rewrite
(N
, Expr_Copy
);
4773 -- Cleanup mapping between formals and actuals for other expansions
4775 Reset_Actual_Mapping_For_Inlined_Call
(Subp
);
4777 end Inline_Static_Function_Call
;
4779 ------------------------
4780 -- Instantiate_Bodies --
4781 ------------------------
4783 -- Generic bodies contain all the non-local references, so an
4784 -- instantiation does not need any more context than Standard
4785 -- itself, even if the instantiation appears in an inner scope.
4786 -- Generic associations have verified that the contract model is
4787 -- satisfied, so that any error that may occur in the analysis of
4788 -- the body is an internal error.
4790 procedure Instantiate_Bodies
is
4792 procedure Instantiate_Body
(Info
: Pending_Body_Info
);
4793 -- Instantiate a pending body
4795 ------------------------
4796 -- Instantiate_Body --
4797 ------------------------
4799 procedure Instantiate_Body
(Info
: Pending_Body_Info
) is
4801 -- If the instantiation node is absent, it has been removed as part
4802 -- of unreachable code.
4804 if No
(Info
.Inst_Node
) then
4807 -- If the instantiation node is a package body, this means that the
4808 -- instance is a compilation unit and the instantiation has already
4809 -- been performed by Build_Instance_Compilation_Unit_Nodes.
4811 elsif Nkind
(Info
.Inst_Node
) = N_Package_Body
then
4814 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
4815 Instantiate_Package_Body
(Info
);
4816 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
4819 Instantiate_Subprogram_Body
(Info
);
4821 end Instantiate_Body
;
4824 Info
: Pending_Body_Info
;
4826 -- Start of processing for Instantiate_Bodies
4829 if Serious_Errors_Detected
= 0 then
4830 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
4831 Push_Scope
(Standard_Standard
);
4832 To_Clean
:= New_Elmt_List
;
4834 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
4838 -- A body instantiation may generate additional instantiations, so
4839 -- the following loop must scan to the end of a possibly expanding
4840 -- set (that's why we cannot simply use a FOR loop here). We must
4841 -- also capture the element lest the set be entirely reallocated.
4844 if Back_End_Inlining
then
4845 while J
<= Called_Pending_Instantiations
.Last
4846 and then Serious_Errors_Detected
= 0
4848 K
:= Called_Pending_Instantiations
.Table
(J
);
4849 Info
:= Pending_Instantiations
.Table
(K
);
4850 Instantiate_Body
(Info
);
4856 while J
<= Pending_Instantiations
.Last
4857 and then Serious_Errors_Detected
= 0
4859 Info
:= Pending_Instantiations
.Table
(J
);
4860 Instantiate_Body
(Info
);
4866 -- Reset the table of instantiations. Additional instantiations
4867 -- may be added through inlining, when additional bodies are
4870 if Back_End_Inlining
then
4871 Called_Pending_Instantiations
.Init
;
4873 Pending_Instantiations
.Init
;
4876 -- We can now complete the cleanup actions of scopes that contain
4877 -- pending instantiations (skipped for generic units, since we
4878 -- never need any cleanups in generic units).
4881 and then not Is_Generic_Unit
(Main_Unit_Entity
)
4884 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
4890 end Instantiate_Bodies
;
4896 function Is_Nested
(E
: Entity_Id
) return Boolean is
4901 while Scop
/= Standard_Standard
loop
4902 if Is_Subprogram
(Scop
) then
4905 elsif Ekind
(Scop
) = E_Task_Type
4906 or else Ekind
(Scop
) = E_Entry
4907 or else Ekind
(Scop
) = E_Entry_Family
4912 Scop
:= Scope
(Scop
);
4918 ------------------------
4919 -- List_Inlining_Info --
4920 ------------------------
4922 procedure List_Inlining_Info
is
4928 if not Debug_Flag_Dot_J
then
4932 -- Generate listing of calls inlined by the frontend
4934 if Present
(Inlined_Calls
) then
4936 Elmt
:= First_Elmt
(Inlined_Calls
);
4937 while Present
(Elmt
) loop
4940 if not In_Internal_Unit
(Nod
) then
4944 Write_Str
("List of calls inlined by the frontend");
4951 Write_Location
(Sloc
(Nod
));
4960 -- Generate listing of calls passed to the backend
4962 if Present
(Backend_Calls
) then
4965 Elmt
:= First_Elmt
(Backend_Calls
);
4966 while Present
(Elmt
) loop
4969 if not In_Internal_Unit
(Nod
) then
4973 Write_Str
("List of inlined calls passed to the backend");
4980 Write_Location
(Sloc
(Nod
));
4988 -- Generate listing of instances inlined for the backend
4990 if Present
(Backend_Instances
) then
4993 Elmt
:= First_Elmt
(Backend_Instances
);
4994 while Present
(Elmt
) loop
4997 if not In_Internal_Unit
(Nod
) then
5001 Write_Str
("List of instances inlined for the backend");
5008 Write_Location
(Sloc
(Nod
));
5016 -- Generate listing of subprograms passed to the backend
5018 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
5021 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
5022 while Present
(Elmt
) loop
5025 if not In_Internal_Unit
(Nod
) then
5030 ("List of inlined subprograms passed to the backend");
5037 Write_Name
(Chars
(Nod
));
5039 Write_Location
(Sloc
(Nod
));
5048 -- Generate listing of subprograms that cannot be inlined by the backend
5050 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
5053 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
5054 while Present
(Elmt
) loop
5057 if not In_Internal_Unit
(Nod
) then
5062 ("List of subprograms that cannot be inlined by backend");
5069 Write_Name
(Chars
(Nod
));
5071 Write_Location
(Sloc
(Nod
));
5079 end List_Inlining_Info
;
5087 Pending_Instantiations
.Release
;
5088 Pending_Instantiations
.Locked
:= True;
5089 Called_Pending_Instantiations
.Release
;
5090 Called_Pending_Instantiations
.Locked
:= True;
5091 Inlined_Bodies
.Release
;
5092 Inlined_Bodies
.Locked
:= True;
5094 Successors
.Locked
:= True;
5096 Inlined
.Locked
:= True;
5099 --------------------------------
5100 -- Remove_Aspects_And_Pragmas --
5101 --------------------------------
5103 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
5104 procedure Remove_Items
(List
: List_Id
);
5105 -- Remove all useless aspects/pragmas from a particular list
5111 procedure Remove_Items
(List
: List_Id
) is
5114 Next_Item
: Node_Id
;
5117 -- Traverse the list looking for an aspect specification or a pragma
5119 Item
:= First
(List
);
5120 while Present
(Item
) loop
5121 Next_Item
:= Next
(Item
);
5123 if Nkind
(Item
) = N_Aspect_Specification
then
5124 Item_Id
:= Identifier
(Item
);
5125 elsif Nkind
(Item
) = N_Pragma
then
5126 Item_Id
:= Pragma_Identifier
(Item
);
5131 if Present
(Item_Id
)
5132 and then Chars
(Item_Id
) in Name_Contract_Cases
5135 | Name_Postcondition
5137 | Name_Refined_Global
5138 | Name_Refined_Depends
5140 | Name_Subprogram_Variant
5153 -- Start of processing for Remove_Aspects_And_Pragmas
5156 Remove_Items
(Aspect_Specifications
(Body_Decl
));
5157 Remove_Items
(Declarations
(Body_Decl
));
5159 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
5160 -- in the body of the subprogram.
5162 Remove_Items
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
5163 end Remove_Aspects_And_Pragmas
;
5165 --------------------------
5166 -- Remove_Dead_Instance --
5167 --------------------------
5169 procedure Remove_Dead_Instance
(N
: Node_Id
) is
5174 while J
<= Pending_Instantiations
.Last
loop
5175 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
5176 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
5182 end Remove_Dead_Instance
;
5184 -------------------------------------------
5185 -- Reset_Actual_Mapping_For_Inlined_Call --
5186 -------------------------------------------
5188 procedure Reset_Actual_Mapping_For_Inlined_Call
(Subp
: Entity_Id
) is
5189 F
: Entity_Id
:= First_Formal
(Subp
);
5192 while Present
(F
) loop
5193 Set_Renamed_Object
(F
, Empty
);
5196 end Reset_Actual_Mapping_For_Inlined_Call
;