1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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_Util
; use Sem_Util
;
51 with Sinfo
; use Sinfo
;
52 with Sinput
; use Sinput
;
53 with Snames
; use Snames
;
54 with Stand
; use Stand
;
56 with Tbuild
; use Tbuild
;
57 with Uintp
; use Uintp
;
58 with Uname
; use Uname
;
62 package body Inline
is
64 Check_Inlining_Restrictions
: constant Boolean := True;
65 -- In the following cases the frontend rejects inlining because they
66 -- are not handled well by the backend. This variable facilitates
67 -- disabling these restrictions to evaluate future versions of the
68 -- GCC backend in which some of the restrictions may be supported.
70 -- - subprograms that have:
71 -- - nested subprograms
73 -- - package declarations
74 -- - task or protected object declarations
75 -- - some of the following statements:
77 -- - asynchronous-select
78 -- - conditional-entry-call
84 Inlined_Calls
: Elist_Id
;
85 -- List of frontend inlined calls
87 Backend_Calls
: Elist_Id
;
88 -- List of inline calls passed to the backend
90 Backend_Instances
: Elist_Id
;
91 -- List of instances inlined for the backend
93 Backend_Inlined_Subps
: Elist_Id
;
94 -- List of subprograms inlined by the backend
96 Backend_Not_Inlined_Subps
: Elist_Id
;
97 -- List of subprograms that cannot be inlined by the backend
99 -----------------------------
100 -- Pending_Instantiations --
101 -----------------------------
103 -- We make entries in this table for the pending instantiations of generic
104 -- bodies that are created during semantic analysis. After the analysis is
105 -- complete, calling Instantiate_Bodies performs the actual instantiations.
107 package Pending_Instantiations
is new Table
.Table
(
108 Table_Component_Type
=> Pending_Body_Info
,
109 Table_Index_Type
=> Int
,
110 Table_Low_Bound
=> 0,
111 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
112 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
113 Table_Name
=> "Pending_Instantiations");
115 -------------------------------------
116 -- Called_Pending_Instantiations --
117 -------------------------------------
119 -- With back-end inlining, the pending instantiations that are not in the
120 -- main unit or subunit are performed only after a call to the subprogram
121 -- instance, or to a subprogram within the package instance, is inlined.
122 -- Since such a call can be within a subsequent pending instantiation,
123 -- we make entries in this table that stores the index of these "called"
124 -- pending instantiations and perform them when the table is populated.
126 package Called_Pending_Instantiations
is new Table
.Table
(
127 Table_Component_Type
=> Int
,
128 Table_Index_Type
=> Int
,
129 Table_Low_Bound
=> 0,
130 Table_Initial
=> Alloc
.Pending_Instantiations_Initial
,
131 Table_Increment
=> Alloc
.Pending_Instantiations_Increment
,
132 Table_Name
=> "Called_Pending_Instantiations");
134 ---------------------------------
135 -- To_Pending_Instantiations --
136 ---------------------------------
138 -- With back-end inlining, we also need to have a map from the pending
139 -- instantiations to their index in the Pending_Instantiations table.
141 Node_Table_Size
: constant := 257;
142 -- Number of headers in hash table
144 subtype Node_Header_Num
is Integer range 0 .. Node_Table_Size
- 1;
145 -- Range of headers in hash table
147 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
;
148 -- Simple hash function for Node_Ids
150 package To_Pending_Instantiations
is new GNAT
.Htable
.Simple_HTable
151 (Header_Num
=> Node_Header_Num
,
162 function Node_Hash
(Id
: Node_Id
) return Node_Header_Num
is
164 return Node_Header_Num
(Id
mod Node_Table_Size
);
171 -- Inlined functions are actually placed in line by the backend if the
172 -- corresponding bodies are available (i.e. compiled). Whenever we find
173 -- a call to an inlined subprogram, we add the name of the enclosing
174 -- compilation unit to a worklist. After all compilation, and after
175 -- expansion of generic bodies, we traverse the list of pending bodies
176 -- and compile them as well.
178 package Inlined_Bodies
is new Table
.Table
(
179 Table_Component_Type
=> Entity_Id
,
180 Table_Index_Type
=> Int
,
181 Table_Low_Bound
=> 0,
182 Table_Initial
=> Alloc
.Inlined_Bodies_Initial
,
183 Table_Increment
=> Alloc
.Inlined_Bodies_Increment
,
184 Table_Name
=> "Inlined_Bodies");
186 -----------------------
187 -- Inline Processing --
188 -----------------------
190 -- For each call to an inlined subprogram, we make entries in a table
191 -- that stores caller and callee, and indicates the call direction from
192 -- one to the other. We also record the compilation unit that contains
193 -- the callee. After analyzing the bodies of all such compilation units,
194 -- we compute the transitive closure of inlined subprograms called from
195 -- the main compilation unit and make it available to the code generator
196 -- in no particular order, thus allowing cycles in the call graph.
198 Last_Inlined
: Entity_Id
:= Empty
;
200 -- For each entry in the table we keep a list of successors in topological
201 -- order, i.e. callers of the current subprogram.
203 type Subp_Index
is new Nat
;
204 No_Subp
: constant Subp_Index
:= 0;
206 -- The subprogram entities are hashed into the Inlined table
208 Num_Hash_Headers
: constant := 512;
210 Hash_Headers
: array (Subp_Index
range 0 .. Num_Hash_Headers
- 1)
213 type Succ_Index
is new Nat
;
214 No_Succ
: constant Succ_Index
:= 0;
216 type Succ_Info
is record
221 -- The following table stores list elements for the successor lists. These
222 -- lists cannot be chained directly through entries in the Inlined table,
223 -- because a given subprogram can appear in several such lists.
225 package Successors
is new Table
.Table
(
226 Table_Component_Type
=> Succ_Info
,
227 Table_Index_Type
=> Succ_Index
,
228 Table_Low_Bound
=> 1,
229 Table_Initial
=> Alloc
.Successors_Initial
,
230 Table_Increment
=> Alloc
.Successors_Increment
,
231 Table_Name
=> "Successors");
233 type Subp_Info
is record
234 Name
: Entity_Id
:= Empty
;
235 Next
: Subp_Index
:= No_Subp
;
236 First_Succ
: Succ_Index
:= No_Succ
;
237 Main_Call
: Boolean := False;
238 Processed
: Boolean := False;
241 package Inlined
is new Table
.Table
(
242 Table_Component_Type
=> Subp_Info
,
243 Table_Index_Type
=> Subp_Index
,
244 Table_Low_Bound
=> 1,
245 Table_Initial
=> Alloc
.Inlined_Initial
,
246 Table_Increment
=> Alloc
.Inlined_Increment
,
247 Table_Name
=> "Inlined");
249 -----------------------
250 -- Local Subprograms --
251 -----------------------
253 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
);
254 -- Make two entries in Inlined table, for an inlined subprogram being
255 -- called, and for the inlined subprogram that contains the call. If
256 -- the call is in the main compilation unit, Caller is Empty.
258 procedure Add_Inlined_Instance
(E
: Entity_Id
);
259 -- Add instance E to the list of inlined instances for the unit
261 procedure Add_Inlined_Subprogram
(E
: Entity_Id
);
262 -- Add subprogram E to the list of inlined subprograms for the unit
264 function Add_Subp
(E
: Entity_Id
) return Subp_Index
;
265 -- Make entry in Inlined table for subprogram E, or return table index
266 -- that already holds E.
268 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
;
269 pragma Inline
(Get_Code_Unit_Entity
);
270 -- Return the entity node for the unit containing E. Always return the spec
273 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean;
274 -- If a candidate for inlining contains type declarations for types with
275 -- nontrivial initialization procedures, they are not worth inlining.
277 function Has_Single_Return
(N
: Node_Id
) return Boolean;
278 -- In general we cannot inline functions that return unconstrained type.
279 -- However, we can handle such functions if all return statements return
280 -- a local variable that is the first declaration in the body of the
281 -- function. In that case the call can be replaced by that local
282 -- variable as is done for other inlined calls.
284 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean;
285 -- Return True if E is in the main unit or its spec or in a subunit
287 function Is_Nested
(E
: Entity_Id
) return Boolean;
288 -- If the function is nested inside some other function, it will always
289 -- be compiled if that function is, so don't add it to the inline list.
290 -- We cannot compile a nested function outside the scope of the containing
291 -- function anyway. This is also the case if the function is defined in a
292 -- task body or within an entry (for example, an initialization procedure).
294 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
);
295 -- Remove all aspects and/or pragmas that have no meaning in inlined body
296 -- Body_Decl. The analysis of these items is performed on the non-inlined
297 -- body. The items currently removed are:
310 ------------------------------
311 -- Deferred Cleanup Actions --
312 ------------------------------
314 -- The cleanup actions for scopes that contain instantiations is delayed
315 -- until after expansion of those instantiations, because they may contain
316 -- finalizable objects or tasks that affect the cleanup code. A scope
317 -- that contains instantiations only needs to be finalized once, even
318 -- if it contains more than one instance. We keep a list of scopes
319 -- that must still be finalized, and call cleanup_actions after all
320 -- the instantiations have been completed.
324 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
);
325 -- Build set of scopes on which cleanup actions must be performed
327 procedure Cleanup_Scopes
;
328 -- Complete cleanup actions on scopes that need it
334 procedure Add_Call
(Called
: Entity_Id
; Caller
: Entity_Id
:= Empty
) is
335 P1
: constant Subp_Index
:= Add_Subp
(Called
);
340 if Present
(Caller
) then
341 P2
:= Add_Subp
(Caller
);
343 -- Add P1 to the list of successors of P2, if not already there.
344 -- Note that P2 may contain more than one call to P1, and only
345 -- one needs to be recorded.
347 J
:= Inlined
.Table
(P2
).First_Succ
;
348 while J
/= No_Succ
loop
349 if Successors
.Table
(J
).Subp
= P1
then
353 J
:= Successors
.Table
(J
).Next
;
356 -- On exit, make a successor entry for P1
358 Successors
.Increment_Last
;
359 Successors
.Table
(Successors
.Last
).Subp
:= P1
;
360 Successors
.Table
(Successors
.Last
).Next
:=
361 Inlined
.Table
(P2
).First_Succ
;
362 Inlined
.Table
(P2
).First_Succ
:= Successors
.Last
;
364 Inlined
.Table
(P1
).Main_Call
:= True;
368 ----------------------
369 -- Add_Inlined_Body --
370 ----------------------
372 procedure Add_Inlined_Body
(E
: Entity_Id
; N
: Node_Id
) is
374 type Inline_Level_Type
is (Dont_Inline
, Inline_Call
, Inline_Package
);
375 -- Level of inlining for the call: Dont_Inline means no inlining,
376 -- Inline_Call means that only the call is considered for inlining,
377 -- Inline_Package means that the call is considered for inlining and
378 -- its package compiled and scanned for more inlining opportunities.
380 function Is_Non_Loading_Expression_Function
381 (Id
: Entity_Id
) return Boolean;
382 -- Determine whether arbitrary entity Id denotes a subprogram which is
385 -- * An expression function
387 -- * A function completed by an expression function where both the
388 -- spec and body are in the same context.
390 function Must_Inline
return Inline_Level_Type
;
391 -- Inlining is only done if the call statement N is in the main unit,
392 -- or within the body of another inlined subprogram.
394 ----------------------------------------
395 -- Is_Non_Loading_Expression_Function --
396 ----------------------------------------
398 function Is_Non_Loading_Expression_Function
399 (Id
: Entity_Id
) return Boolean
406 -- A stand-alone expression function is transformed into a spec-body
407 -- pair in-place. Since both the spec and body are in the same list,
408 -- the inlining of such an expression function does not need to load
411 if Is_Expression_Function
(Id
) then
414 -- A function may be completed by an expression function
416 elsif Ekind
(Id
) = E_Function
then
417 Spec_Decl
:= Unit_Declaration_Node
(Id
);
419 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
then
420 Body_Id
:= Corresponding_Body
(Spec_Decl
);
422 if Present
(Body_Id
) then
423 Body_Decl
:= Unit_Declaration_Node
(Body_Id
);
425 -- The inlining of a completing expression function does
426 -- not need to load anything extra when both the spec and
427 -- body are in the same context.
430 Was_Expression_Function
(Body_Decl
)
431 and then Parent
(Spec_Decl
) = Parent
(Body_Decl
);
437 end Is_Non_Loading_Expression_Function
;
443 function Must_Inline
return Inline_Level_Type
is
448 -- Check if call is in main unit
450 Scop
:= Current_Scope
;
452 -- Do not try to inline if scope is standard. This could happen, for
453 -- example, for a call to Add_Global_Declaration, and it causes
454 -- trouble to try to inline at this level.
456 if Scop
= Standard_Standard
then
460 -- Otherwise lookup scope stack to outer scope
462 while Scope
(Scop
) /= Standard_Standard
463 and then not Is_Child_Unit
(Scop
)
465 Scop
:= Scope
(Scop
);
468 Comp
:= Parent
(Scop
);
469 while Nkind
(Comp
) /= N_Compilation_Unit
loop
470 Comp
:= Parent
(Comp
);
473 -- If the call is in the main unit, inline the call and compile the
474 -- package of the subprogram to find more calls to be inlined.
476 if Comp
= Cunit
(Main_Unit
)
477 or else Comp
= Library_Unit
(Cunit
(Main_Unit
))
480 return Inline_Package
;
483 -- The call is not in the main unit. See if it is in some subprogram
484 -- that can be inlined outside its unit. If so, inline the call and,
485 -- if the inlining level is set to 1, stop there; otherwise also
486 -- compile the package as above.
488 Scop
:= Current_Scope
;
489 while Scope
(Scop
) /= Standard_Standard
490 and then not Is_Child_Unit
(Scop
)
492 if Is_Overloadable
(Scop
)
493 and then Is_Inlined
(Scop
)
494 and then not Is_Nested
(Scop
)
498 if Inline_Level
= 1 then
501 return Inline_Package
;
505 Scop
:= Scope
(Scop
);
513 Level
: Inline_Level_Type
;
515 -- Start of processing for Add_Inlined_Body
518 Append_New_Elmt
(N
, To
=> Backend_Calls
);
520 -- Skip subprograms that cannot or need not be inlined outside their
521 -- unit or parent subprogram.
523 if Is_Abstract_Subprogram
(E
)
524 or else Convention
(E
) = Convention_Protected
525 or else In_Main_Unit_Or_Subunit
(E
)
526 or else Is_Nested
(E
)
531 -- Find out whether the call must be inlined. Unless the result is
532 -- Dont_Inline, Must_Inline also creates an edge for the call in the
533 -- callgraph; however, it will not be activated until after Is_Called
534 -- is set on the subprogram.
536 Level
:= Must_Inline
;
538 if Level
= Dont_Inline
then
542 -- If a previous call to the subprogram has been inlined, nothing to do
544 if Is_Called
(E
) then
548 -- If the subprogram is an instance, then inline the instance
550 if Is_Generic_Instance
(E
) then
551 Add_Inlined_Instance
(E
);
554 -- Mark the subprogram as called
558 -- If the call was generated by the compiler and is to a subprogram in
559 -- a run-time unit, we need to suppress debugging information for it,
560 -- so that the code that is eventually inlined will not affect the
561 -- debugging of the program. We do not do it if the call comes from
562 -- source because, even if the call is inlined, the user may expect it
563 -- to be present in the debugging information.
565 if not Comes_From_Source
(N
)
566 and then In_Extended_Main_Source_Unit
(N
)
567 and then Is_Predefined_Unit
(Get_Source_Unit
(E
))
569 Set_Needs_Debug_Info
(E
, False);
572 -- If the subprogram is an expression function, or is completed by one
573 -- where both the spec and body are in the same context, then there is
574 -- no need to load any package body since the body of the function is
577 if Is_Non_Loading_Expression_Function
(E
) then
581 -- Find unit containing E, and add to list of inlined bodies if needed.
582 -- Library-level functions must be handled specially, because there is
583 -- no enclosing package to retrieve. In this case, it is the body of
584 -- the function that will have to be loaded.
587 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
591 Inlined_Bodies
.Increment_Last
;
592 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := E
;
595 pragma Assert
(Ekind
(Pack
) = E_Package
);
597 -- If the subprogram is within an instance, inline the instance
599 if Comes_From_Source
(E
) then
602 while Present
(Inst
) and then Inst
/= Standard_Standard
loop
603 exit when Is_Generic_Instance
(Inst
);
604 Inst
:= Scope
(Inst
);
608 and then Is_Generic_Instance
(Inst
)
609 and then not Is_Called
(Inst
)
611 Inst_Decl
:= Unit_Declaration_Node
(Inst
);
613 -- Do not inline the instance if the body already exists,
614 -- or the instance node is simply missing.
616 if Present
(Corresponding_Body
(Inst_Decl
))
617 or else (Nkind
(Parent
(Inst_Decl
)) /= N_Compilation_Unit
618 and then No
(Next
(Inst_Decl
)))
620 Set_Is_Called
(Inst
);
622 Add_Inlined_Instance
(Inst
);
627 -- If the unit containing E is an instance, nothing more to do
629 if Is_Generic_Instance
(Pack
) then
632 -- Do not inline the package if the subprogram is an init proc
633 -- or other internally generated subprogram, because in that
634 -- case the subprogram body appears in the same unit that
635 -- declares the type, and that body is visible to the back end.
636 -- Do not inline it either if it is in the main unit.
637 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
638 -- calls if the back end takes care of inlining the call.
639 -- Note that Level is in Inline_Call | Inline_Package here.
641 elsif ((Level
= Inline_Call
642 and then Has_Pragma_Inline_Always
(E
)
643 and then Back_End_Inlining
)
644 or else Level
= Inline_Package
)
645 and then not Is_Inlined
(Pack
)
646 and then not Is_Internal
(E
)
647 and then not In_Main_Unit_Or_Subunit
(Pack
)
649 Set_Is_Inlined
(Pack
);
650 Inlined_Bodies
.Increment_Last
;
651 Inlined_Bodies
.Table
(Inlined_Bodies
.Last
) := Pack
;
655 -- Ensure that Analyze_Inlined_Bodies will be invoked after
656 -- completing the analysis of the current unit.
658 Inline_Processing_Required
:= True;
660 end Add_Inlined_Body
;
662 --------------------------
663 -- Add_Inlined_Instance --
664 --------------------------
666 procedure Add_Inlined_Instance
(E
: Entity_Id
) is
667 Decl_Node
: constant Node_Id
:= Unit_Declaration_Node
(E
);
671 -- This machinery is only used with back-end inlining
673 if not Back_End_Inlining
then
677 -- Register the instance in the list
679 Append_New_Elmt
(Decl_Node
, To
=> Backend_Instances
);
681 -- Retrieve the index of its corresponding pending instantiation
682 -- and mark this corresponding pending instantiation as needed.
684 Index
:= To_Pending_Instantiations
.Get
(Decl_Node
);
686 Called_Pending_Instantiations
.Append
(Index
);
688 pragma Assert
(False);
693 end Add_Inlined_Instance
;
695 ----------------------------
696 -- Add_Inlined_Subprogram --
697 ----------------------------
699 procedure Add_Inlined_Subprogram
(E
: Entity_Id
) is
700 Decl
: constant Node_Id
:= Parent
(Declaration_Node
(E
));
701 Pack
: constant Entity_Id
:= Get_Code_Unit_Entity
(E
);
703 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
);
704 -- Append Subp to the list of subprograms inlined by the backend
706 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
);
707 -- Append Subp to the list of subprograms that cannot be inlined by
710 -----------------------------------------
711 -- Register_Backend_Inlined_Subprogram --
712 -----------------------------------------
714 procedure Register_Backend_Inlined_Subprogram
(Subp
: Entity_Id
) is
716 Append_New_Elmt
(Subp
, To
=> Backend_Inlined_Subps
);
717 end Register_Backend_Inlined_Subprogram
;
719 ---------------------------------------------
720 -- Register_Backend_Not_Inlined_Subprogram --
721 ---------------------------------------------
723 procedure Register_Backend_Not_Inlined_Subprogram
(Subp
: Entity_Id
) is
725 Append_New_Elmt
(Subp
, To
=> Backend_Not_Inlined_Subps
);
726 end Register_Backend_Not_Inlined_Subprogram
;
728 -- Start of processing for Add_Inlined_Subprogram
731 -- We can inline the subprogram if its unit is known to be inlined or is
732 -- an instance whose body will be analyzed anyway or the subprogram was
733 -- generated as a body by the compiler (for example an initialization
734 -- procedure) or its declaration was provided along with the body (for
735 -- example an expression function) and it does not declare types with
736 -- nontrivial initialization procedures.
738 if (Is_Inlined
(Pack
)
739 or else Is_Generic_Instance
(Pack
)
740 or else Nkind
(Decl
) = N_Subprogram_Body
741 or else Present
(Corresponding_Body
(Decl
)))
742 and then not Has_Initialized_Type
(E
)
744 Register_Backend_Inlined_Subprogram
(E
);
746 if No
(Last_Inlined
) then
747 Set_First_Inlined_Subprogram
(Cunit
(Main_Unit
), E
);
749 Set_Next_Inlined_Subprogram
(Last_Inlined
, E
);
755 Register_Backend_Not_Inlined_Subprogram
(E
);
757 end Add_Inlined_Subprogram
;
759 --------------------------------
760 -- Add_Pending_Instantiation --
761 --------------------------------
763 procedure Add_Pending_Instantiation
(Inst
: Node_Id
; Act_Decl
: Node_Id
) is
764 Act_Decl_Id
: Entity_Id
;
768 -- Here is a defense against a ludicrous number of instantiations
769 -- caused by a circular set of instantiation attempts.
771 if Pending_Instantiations
.Last
+ 1 >= Maximum_Instantiations
then
772 Error_Msg_Uint_1
:= UI_From_Int
(Maximum_Instantiations
);
773 Error_Msg_N
("too many instantiations, exceeds max of^", Inst
);
774 Error_Msg_N
("\limit can be changed using -gnateinn switch", Inst
);
775 raise Unrecoverable_Error
;
778 -- Capture the body of the generic instantiation along with its context
779 -- for later processing by Instantiate_Bodies.
781 Pending_Instantiations
.Append
782 ((Act_Decl
=> Act_Decl
,
783 Config_Switches
=> Save_Config_Switches
,
784 Current_Sem_Unit
=> Current_Sem_Unit
,
785 Expander_Status
=> Expander_Active
,
787 Local_Suppress_Stack_Top
=> Local_Suppress_Stack_Top
,
788 Scope_Suppress
=> Scope_Suppress
,
789 Warnings
=> Save_Warnings
));
791 -- With back-end inlining, also associate the index to the instantiation
793 if Back_End_Inlining
then
794 Act_Decl_Id
:= Defining_Entity
(Act_Decl
);
795 Index
:= Pending_Instantiations
.Last
;
797 To_Pending_Instantiations
.Set
(Act_Decl
, Index
);
799 -- If an instantiation is in the main unit or subunit, or is a nested
800 -- subprogram, then its body is needed as per the analysis done in
801 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
803 if In_Main_Unit_Or_Subunit
(Act_Decl_Id
)
804 or else (Is_Subprogram
(Act_Decl_Id
)
805 and then Is_Nested
(Act_Decl_Id
))
807 Called_Pending_Instantiations
.Append
(Index
);
809 Set_Is_Called
(Act_Decl_Id
);
812 end Add_Pending_Instantiation
;
814 ------------------------
815 -- Add_Scope_To_Clean --
816 ------------------------
818 procedure Add_Scope_To_Clean
(Inst
: Entity_Id
) is
819 Scop
: constant Entity_Id
:= Enclosing_Dynamic_Scope
(Inst
);
823 -- If the instance appears in a library-level package declaration,
824 -- all finalization is global, and nothing needs doing here.
826 if Scop
= Standard_Standard
then
830 -- If the instance is within a generic unit, no finalization code
831 -- can be generated. Note that at this point all bodies have been
832 -- analyzed, and the scope stack itself is not present, and the flag
833 -- Inside_A_Generic is not set.
840 while Present
(S
) and then S
/= Standard_Standard
loop
841 if Is_Generic_Unit
(S
) then
849 Elmt
:= First_Elmt
(To_Clean
);
850 while Present
(Elmt
) loop
851 if Node
(Elmt
) = Scop
then
855 Elmt
:= Next_Elmt
(Elmt
);
858 Append_Elmt
(Scop
, To_Clean
);
859 end Add_Scope_To_Clean
;
865 function Add_Subp
(E
: Entity_Id
) return Subp_Index
is
866 Index
: Subp_Index
:= Subp_Index
(E
) mod Num_Hash_Headers
;
870 -- Initialize entry in Inlined table
872 procedure New_Entry
is
874 Inlined
.Increment_Last
;
875 Inlined
.Table
(Inlined
.Last
).Name
:= E
;
876 Inlined
.Table
(Inlined
.Last
).Next
:= No_Subp
;
877 Inlined
.Table
(Inlined
.Last
).First_Succ
:= No_Succ
;
878 Inlined
.Table
(Inlined
.Last
).Main_Call
:= False;
879 Inlined
.Table
(Inlined
.Last
).Processed
:= False;
882 -- Start of processing for Add_Subp
885 if Hash_Headers
(Index
) = No_Subp
then
887 Hash_Headers
(Index
) := Inlined
.Last
;
891 J
:= Hash_Headers
(Index
);
892 while J
/= No_Subp
loop
893 if Inlined
.Table
(J
).Name
= E
then
897 J
:= Inlined
.Table
(J
).Next
;
901 -- On exit, subprogram was not found. Enter in table. Index is
902 -- the current last entry on the hash chain.
905 Inlined
.Table
(Index
).Next
:= Inlined
.Last
;
910 ----------------------------
911 -- Analyze_Inlined_Bodies --
912 ----------------------------
914 procedure Analyze_Inlined_Bodies
is
921 type Pending_Index
is new Nat
;
923 package Pending_Inlined
is new Table
.Table
(
924 Table_Component_Type
=> Subp_Index
,
925 Table_Index_Type
=> Pending_Index
,
926 Table_Low_Bound
=> 1,
927 Table_Initial
=> Alloc
.Inlined_Initial
,
928 Table_Increment
=> Alloc
.Inlined_Increment
,
929 Table_Name
=> "Pending_Inlined");
930 -- The workpile used to compute the transitive closure
932 -- Start of processing for Analyze_Inlined_Bodies
935 if Serious_Errors_Detected
= 0 then
936 Push_Scope
(Standard_Standard
);
939 while J
<= Inlined_Bodies
.Last
940 and then Serious_Errors_Detected
= 0
942 Pack
:= Inlined_Bodies
.Table
(J
);
944 and then Scope
(Pack
) /= Standard_Standard
945 and then not Is_Child_Unit
(Pack
)
947 Pack
:= Scope
(Pack
);
950 Comp_Unit
:= Parent
(Pack
);
951 while Present
(Comp_Unit
)
952 and then Nkind
(Comp_Unit
) /= N_Compilation_Unit
954 Comp_Unit
:= Parent
(Comp_Unit
);
957 -- Load the body if it exists and contains inlineable entities,
958 -- unless it is the main unit, or is an instance whose body has
959 -- already been analyzed.
961 if Present
(Comp_Unit
)
962 and then Comp_Unit
/= Cunit
(Main_Unit
)
963 and then Body_Required
(Comp_Unit
)
965 (Nkind
(Unit
(Comp_Unit
)) /= N_Package_Declaration
967 (No
(Corresponding_Body
(Unit
(Comp_Unit
)))
968 and then Body_Needed_For_Inlining
969 (Defining_Entity
(Unit
(Comp_Unit
)))))
972 Bname
: constant Unit_Name_Type
:=
973 Get_Body_Name
(Get_Unit_Name
(Unit
(Comp_Unit
)));
978 if not Is_Loaded
(Bname
) then
979 Style_Check
:= False;
980 Load_Needed_Body
(Comp_Unit
, OK
);
984 -- Warn that a body was not available for inlining
987 Error_Msg_Unit_1
:= Bname
;
989 ("one or more inlined subprograms accessed in $!??",
992 Get_File_Name
(Bname
, Subunit
=> False);
993 Error_Msg_N
("\but file{ was not found!??", Comp_Unit
);
1001 if J
> Inlined_Bodies
.Last
then
1003 -- The analysis of required bodies may have produced additional
1004 -- generic instantiations. To obtain further inlining, we need
1005 -- to perform another round of generic body instantiations.
1009 -- Symmetrically, the instantiation of required generic bodies
1010 -- may have caused additional bodies to be inlined. To obtain
1011 -- further inlining, we keep looping over the inlined bodies.
1015 -- The list of inlined subprograms is an overestimate, because it
1016 -- includes inlined functions called from functions that are compiled
1017 -- as part of an inlined package, but are not themselves called. An
1018 -- accurate computation of just those subprograms that are needed
1019 -- requires that we perform a transitive closure over the call graph,
1020 -- starting from calls in the main compilation unit.
1022 for Index
in Inlined
.First
.. Inlined
.Last
loop
1023 if not Is_Called
(Inlined
.Table
(Index
).Name
) then
1025 -- This means that Add_Inlined_Body added the subprogram to the
1026 -- table but wasn't able to handle its code unit. Do nothing.
1028 Inlined
.Table
(Index
).Processed
:= True;
1030 elsif Inlined
.Table
(Index
).Main_Call
then
1031 Pending_Inlined
.Increment_Last
;
1032 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Index
;
1033 Inlined
.Table
(Index
).Processed
:= True;
1036 Set_Is_Called
(Inlined
.Table
(Index
).Name
, False);
1040 -- Iterate over the workpile until it is emptied, propagating the
1041 -- Is_Called flag to the successors of the processed subprogram.
1043 while Pending_Inlined
.Last
>= Pending_Inlined
.First
loop
1044 Subp
:= Pending_Inlined
.Table
(Pending_Inlined
.Last
);
1045 Pending_Inlined
.Decrement_Last
;
1047 S
:= Inlined
.Table
(Subp
).First_Succ
;
1049 while S
/= No_Succ
loop
1050 Subp
:= Successors
.Table
(S
).Subp
;
1052 if not Inlined
.Table
(Subp
).Processed
then
1053 Set_Is_Called
(Inlined
.Table
(Subp
).Name
);
1054 Pending_Inlined
.Increment_Last
;
1055 Pending_Inlined
.Table
(Pending_Inlined
.Last
) := Subp
;
1056 Inlined
.Table
(Subp
).Processed
:= True;
1059 S
:= Successors
.Table
(S
).Next
;
1063 -- Finally add the called subprograms to the list of inlined
1064 -- subprograms for the unit.
1066 for Index
in Inlined
.First
.. Inlined
.Last
loop
1067 if Is_Called
(Inlined
.Table
(Index
).Name
) then
1068 Add_Inlined_Subprogram
(Inlined
.Table
(Index
).Name
);
1074 end Analyze_Inlined_Bodies
;
1076 --------------------------
1077 -- Build_Body_To_Inline --
1078 --------------------------
1080 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
1081 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
1082 Analysis_Status
: constant Boolean := Full_Analysis
;
1083 Original_Body
: Node_Id
;
1084 Body_To_Analyze
: Node_Id
;
1085 Max_Size
: constant := 10;
1087 function Has_Extended_Return
return Boolean;
1088 -- This function returns True if the subprogram has an extended return
1091 function Has_Pending_Instantiation
return Boolean;
1092 -- If some enclosing body contains instantiations that appear before
1093 -- the corresponding generic body, the enclosing body has a freeze node
1094 -- so that it can be elaborated after the generic itself. This might
1095 -- conflict with subsequent inlinings, so that it is unsafe to try to
1096 -- inline in such a case.
1098 function Has_Single_Return_In_GNATprove_Mode
return Boolean;
1099 -- This function is called only in GNATprove mode, and it returns
1100 -- True if the subprogram has no return statement or a single return
1101 -- statement as last statement. It returns False for subprogram with
1102 -- a single return as last statement inside one or more blocks, as
1103 -- inlining would generate gotos in that case as well (although the
1104 -- goto is useless in that case).
1106 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean;
1107 -- If the body of the subprogram includes a call that returns an
1108 -- unconstrained type, the secondary stack is involved, and it is
1109 -- not worth inlining.
1111 -------------------------
1112 -- Has_Extended_Return --
1113 -------------------------
1115 function Has_Extended_Return
return Boolean is
1116 Body_To_Inline
: constant Node_Id
:= N
;
1118 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1119 -- Returns OK on node N if this is not an extended return statement
1125 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1128 when N_Extended_Return_Statement
=>
1131 -- Skip locally declared subprogram bodies inside the body to
1132 -- inline, as the return statements inside those do not count.
1134 when N_Subprogram_Body
=>
1135 if N
= Body_To_Inline
then
1146 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1148 -- Start of processing for Has_Extended_Return
1151 return Check_All_Returns
(N
) /= OK
;
1152 end Has_Extended_Return
;
1154 -------------------------------
1155 -- Has_Pending_Instantiation --
1156 -------------------------------
1158 function Has_Pending_Instantiation
return Boolean is
1163 while Present
(S
) loop
1164 if Is_Compilation_Unit
(S
)
1165 or else Is_Child_Unit
(S
)
1169 elsif Ekind
(S
) = E_Package
1170 and then Has_Forward_Instantiation
(S
)
1179 end Has_Pending_Instantiation
;
1181 -----------------------------------------
1182 -- Has_Single_Return_In_GNATprove_Mode --
1183 -----------------------------------------
1185 function Has_Single_Return_In_GNATprove_Mode
return Boolean is
1186 Body_To_Inline
: constant Node_Id
:= N
;
1187 Last_Statement
: Node_Id
:= Empty
;
1189 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
1190 -- Returns OK on node N if this is not a return statement different
1191 -- from the last statement in the subprogram.
1197 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
1200 when N_Extended_Return_Statement
1201 | N_Simple_Return_Statement
1203 if N
= Last_Statement
then
1209 -- Skip locally declared subprogram bodies inside the body to
1210 -- inline, as the return statements inside those do not count.
1212 when N_Subprogram_Body
=>
1213 if N
= Body_To_Inline
then
1224 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
1226 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1229 -- Retrieve the last statement
1231 Last_Statement
:= Last
(Statements
(Handled_Statement_Sequence
(N
)));
1233 -- Check that the last statement is the only possible return
1234 -- statement in the subprogram.
1236 return Check_All_Returns
(N
) = OK
;
1237 end Has_Single_Return_In_GNATprove_Mode
;
1239 --------------------------
1240 -- Uses_Secondary_Stack --
1241 --------------------------
1243 function Uses_Secondary_Stack
(Bod
: Node_Id
) return Boolean is
1244 function Check_Call
(N
: Node_Id
) return Traverse_Result
;
1245 -- Look for function calls that return an unconstrained type
1251 function Check_Call
(N
: Node_Id
) return Traverse_Result
is
1253 if Nkind
(N
) = N_Function_Call
1254 and then Is_Entity_Name
(Name
(N
))
1255 and then Is_Composite_Type
(Etype
(Entity
(Name
(N
))))
1256 and then not Is_Constrained
(Etype
(Entity
(Name
(N
))))
1259 ("cannot inline & (call returns unconstrained type)?",
1267 function Check_Calls
is new Traverse_Func
(Check_Call
);
1270 return Check_Calls
(Bod
) = Abandon
;
1271 end Uses_Secondary_Stack
;
1273 -- Start of processing for Build_Body_To_Inline
1276 -- Return immediately if done already
1278 if Nkind
(Decl
) = N_Subprogram_Declaration
1279 and then Present
(Body_To_Inline
(Decl
))
1283 -- Subprograms that have return statements in the middle of the body are
1284 -- inlined with gotos. GNATprove does not currently support gotos, so
1285 -- we prevent such inlining.
1287 elsif GNATprove_Mode
1288 and then not Has_Single_Return_In_GNATprove_Mode
1290 Cannot_Inline
("cannot inline & (multiple returns)?", N
, Spec_Id
);
1293 -- Functions that return controlled types cannot currently be inlined
1294 -- because they require secondary stack handling; controlled actions
1295 -- may also interfere in complex ways with inlining.
1297 elsif Ekind
(Spec_Id
) = E_Function
1298 and then Needs_Finalization
(Etype
(Spec_Id
))
1301 ("cannot inline & (controlled return type)?", N
, Spec_Id
);
1305 if Present
(Declarations
(N
))
1306 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
1311 if Present
(Handled_Statement_Sequence
(N
)) then
1312 if Present
(Exception_Handlers
(Handled_Statement_Sequence
(N
))) then
1314 ("cannot inline& (exception handler)?",
1315 First
(Exception_Handlers
(Handled_Statement_Sequence
(N
))),
1319 elsif Has_Excluded_Statement
1320 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
1326 -- We do not inline a subprogram that is too large, unless it is marked
1327 -- Inline_Always or we are in GNATprove mode. This pragma does not
1328 -- suppress the other checks on inlining (forbidden declarations,
1331 if not (Has_Pragma_Inline_Always
(Spec_Id
) or else GNATprove_Mode
)
1332 and then List_Length
1333 (Statements
(Handled_Statement_Sequence
(N
))) > Max_Size
1335 Cannot_Inline
("cannot inline& (body too large)?", N
, Spec_Id
);
1339 if Has_Pending_Instantiation
then
1341 ("cannot inline& (forward instance within enclosing body)?",
1346 -- Within an instance, the body to inline must be treated as a nested
1347 -- generic, so that the proper global references are preserved.
1349 -- Note that we do not do this at the library level, because it is not
1350 -- needed, and furthermore this causes trouble if front-end inlining
1351 -- is activated (-gnatN).
1353 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1354 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
1355 Original_Body
:= Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
1357 Original_Body
:= Copy_Separate_Tree
(N
);
1360 -- We need to capture references to the formals in order to substitute
1361 -- the actuals at the point of inlining, i.e. instantiation. To treat
1362 -- the formals as globals to the body to inline, we nest it within a
1363 -- dummy parameterless subprogram, declared within the real one. To
1364 -- avoid generating an internal name (which is never public, and which
1365 -- affects serial numbers of other generated names), we use an internal
1366 -- symbol that cannot conflict with user declarations.
1368 Set_Parameter_Specifications
(Specification
(Original_Body
), No_List
);
1369 Set_Defining_Unit_Name
1370 (Specification
(Original_Body
),
1371 Make_Defining_Identifier
(Sloc
(N
), Name_uParent
));
1372 Set_Corresponding_Spec
(Original_Body
, Empty
);
1374 -- Remove all aspects/pragmas that have no meaning in an inlined body
1376 Remove_Aspects_And_Pragmas
(Original_Body
);
1379 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
1381 -- Set return type of function, which is also global and does not need
1384 if Ekind
(Spec_Id
) = E_Function
then
1385 Set_Result_Definition
1386 (Specification
(Body_To_Analyze
),
1387 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
1390 if No
(Declarations
(N
)) then
1391 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
1393 Append
(Body_To_Analyze
, Declarations
(N
));
1396 -- The body to inline is preanalyzed. In GNATprove mode we must disable
1397 -- full analysis as well so that light expansion does not take place
1398 -- either, and name resolution is unaffected.
1400 Expander_Mode_Save_And_Set
(False);
1401 Full_Analysis
:= False;
1403 Analyze
(Body_To_Analyze
);
1404 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
1405 Save_Global_References
(Original_Body
);
1407 Remove
(Body_To_Analyze
);
1409 Expander_Mode_Restore
;
1410 Full_Analysis
:= Analysis_Status
;
1412 -- Restore environment if previously saved
1414 if In_Instance
and then Scope
(Current_Scope
) /= Standard_Standard
then
1418 -- Functions that return unconstrained composite types require
1419 -- secondary stack handling, and cannot currently be inlined, unless
1420 -- all return statements return a local variable that is the first
1421 -- local declaration in the body. We had to delay this check until
1422 -- the body of the function is analyzed since Has_Single_Return()
1423 -- requires a minimum decoration.
1425 if Ekind
(Spec_Id
) = E_Function
1426 and then not Is_Scalar_Type
(Etype
(Spec_Id
))
1427 and then not Is_Access_Type
(Etype
(Spec_Id
))
1428 and then not Is_Constrained
(Etype
(Spec_Id
))
1430 if not Has_Single_Return
(Body_To_Analyze
)
1432 -- Skip inlining if the function returns an unconstrained type
1433 -- using an extended return statement, since this part of the
1434 -- new inlining model is not yet supported by the current
1435 -- implementation. ???
1437 or else (Returns_Unconstrained_Type
(Spec_Id
)
1438 and then Has_Extended_Return
)
1441 ("cannot inline & (unconstrained return type)?", N
, Spec_Id
);
1445 -- If secondary stack is used, there is no point in inlining. We have
1446 -- already issued the warning in this case, so nothing to do.
1448 elsif Uses_Secondary_Stack
(Body_To_Analyze
) then
1452 Set_Body_To_Inline
(Decl
, Original_Body
);
1453 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
1454 Set_Is_Inlined
(Spec_Id
);
1455 end Build_Body_To_Inline
;
1457 -------------------------------------------
1458 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1459 -------------------------------------------
1461 function Call_Can_Be_Inlined_In_GNATprove_Mode
1463 Subp
: Entity_Id
) return Boolean
1469 F
:= First_Formal
(Subp
);
1470 A
:= First_Actual
(N
);
1471 while Present
(F
) loop
1472 if Ekind
(F
) /= E_Out_Parameter
1473 and then not Same_Type
(Etype
(F
), Etype
(A
))
1475 (Is_By_Reference_Type
(Etype
(A
))
1476 or else Is_Limited_Type
(Etype
(A
)))
1486 end Call_Can_Be_Inlined_In_GNATprove_Mode
;
1488 --------------------------------------
1489 -- Can_Be_Inlined_In_GNATprove_Mode --
1490 --------------------------------------
1492 function Can_Be_Inlined_In_GNATprove_Mode
1493 (Spec_Id
: Entity_Id
;
1494 Body_Id
: Entity_Id
) return Boolean
1496 function Has_Formal_Or_Result_Of_Deep_Type
1497 (Id
: Entity_Id
) return Boolean;
1498 -- Returns true if the subprogram has at least one formal parameter or
1499 -- a return type of a deep type: either an access type or a composite
1500 -- type containing an access type.
1502 function Has_Formal_With_Discriminant_Dependent_Fields
1503 (Id
: Entity_Id
) return Boolean;
1504 -- Returns true if the subprogram has at least one formal parameter of
1505 -- an unconstrained record type with per-object constraints on component
1508 function Has_Some_Contract
(Id
: Entity_Id
) return Boolean;
1509 -- Return True if subprogram Id has any contract. The presence of
1510 -- Extensions_Visible or Volatile_Function is also considered as a
1513 function Is_Unit_Subprogram
(Id
: Entity_Id
) return Boolean;
1514 -- Return True if subprogram Id defines a compilation unit
1515 -- Shouldn't this be in Sem_Aux???
1517 function In_Package_Spec
(Id
: Entity_Id
) return Boolean;
1518 -- Return True if subprogram Id is defined in the package specification,
1519 -- either its visible or private part.
1521 function Maybe_Traversal_Function
(Id
: Entity_Id
) return Boolean;
1522 -- Return True if subprogram Id could be a traversal function, as
1523 -- defined in SPARK RM 3.10. This is only a safe approximation, as the
1524 -- knowledge of the SPARK boundary is needed to determine exactly
1525 -- traversal functions.
1527 ---------------------------------------
1528 -- Has_Formal_Or_Result_Of_Deep_Type --
1529 ---------------------------------------
1531 function Has_Formal_Or_Result_Of_Deep_Type
1532 (Id
: Entity_Id
) return Boolean
1534 function Is_Deep
(Typ
: Entity_Id
) return Boolean;
1535 -- Return True if Typ is deep: either an access type or a composite
1536 -- type containing an access type.
1542 function Is_Deep
(Typ
: Entity_Id
) return Boolean is
1544 case Type_Kind
'(Ekind (Typ)) is
1551 return Is_Deep (Component_Type (Typ));
1555 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
1557 while Present (Comp) loop
1558 if Is_Deep (Etype (Comp)) then
1561 Next_Component_Or_Discriminant (Comp);
1567 | E_String_Literal_Subtype
1577 | E_Limited_Private_Type
1578 | E_Limited_Private_Subtype
1580 -- Conservatively consider that the type might be deep if
1581 -- its completion has not been seen yet.
1583 if No (Underlying_Type (Typ)) then
1586 -- Do not peek under a private type if its completion has
1587 -- SPARK_Mode Off. In such a case, a deep type is considered
1588 -- by GNATprove to be not deep.
1590 elsif Present (Full_View (Typ))
1591 and then Present (SPARK_Pragma (Full_View (Typ)))
1592 and then Get_SPARK_Mode_From_Annotation
1593 (SPARK_Pragma (Full_View (Typ))) = Off
1597 -- Otherwise peek under the private type.
1600 return Is_Deep (Underlying_Type (Typ));
1607 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1609 Formal_Typ : Entity_Id;
1611 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
1614 -- Inspect all parameters of the subprogram looking for a formal
1617 Formal := First_Formal (Subp_Id);
1618 while Present (Formal) loop
1619 Formal_Typ := Etype (Formal);
1621 if Is_Deep (Formal_Typ) then
1625 Next_Formal (Formal);
1628 -- Check whether this is a function whose return type is deep
1630 if Ekind (Subp_Id) = E_Function
1631 and then Is_Deep (Etype (Subp_Id))
1637 end Has_Formal_Or_Result_Of_Deep_Type;
1639 ---------------------------------------------------
1640 -- Has_Formal_With_Discriminant_Dependent_Fields --
1641 ---------------------------------------------------
1643 function Has_Formal_With_Discriminant_Dependent_Fields
1644 (Id : Entity_Id) return Boolean
1646 function Has_Discriminant_Dependent_Component
1647 (Typ : Entity_Id) return Boolean;
1648 -- Determine whether unconstrained record type Typ has at least one
1649 -- component that depends on a discriminant.
1651 ------------------------------------------
1652 -- Has_Discriminant_Dependent_Component --
1653 ------------------------------------------
1655 function Has_Discriminant_Dependent_Component
1656 (Typ : Entity_Id) return Boolean
1661 -- Inspect all components of the record type looking for one that
1662 -- depends on a discriminant.
1664 Comp := First_Component (Typ);
1665 while Present (Comp) loop
1666 if Has_Discriminant_Dependent_Constraint (Comp) then
1670 Next_Component (Comp);
1674 end Has_Discriminant_Dependent_Component;
1678 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1680 Formal_Typ : Entity_Id;
1682 -- Start of processing for
1683 -- Has_Formal_With_Discriminant_Dependent_Fields
1686 -- Inspect all parameters of the subprogram looking for a formal
1687 -- of an unconstrained record type with at least one discriminant
1688 -- dependent component.
1690 Formal := First_Formal (Subp_Id);
1691 while Present (Formal) loop
1692 Formal_Typ := Etype (Formal);
1694 if Is_Record_Type (Formal_Typ)
1695 and then not Is_Constrained (Formal_Typ)
1696 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1701 Next_Formal (Formal);
1705 end Has_Formal_With_Discriminant_Dependent_Fields;
1707 -----------------------
1708 -- Has_Some_Contract --
1709 -----------------------
1711 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1715 -- A call to an expression function may precede the actual body which
1716 -- is inserted at the end of the enclosing declarations. Ensure that
1717 -- the related entity is decorated before inspecting the contract.
1719 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1720 Items := Contract (Id);
1722 -- Note that Classifications is not Empty when Extensions_Visible
1723 -- or Volatile_Function is present, which causes such subprograms
1724 -- to be considered to have a contract here. This is fine as we
1725 -- want to avoid inlining these too.
1727 return Present (Items)
1728 and then (Present (Pre_Post_Conditions (Items)) or else
1729 Present (Contract_Test_Cases (Items)) or else
1730 Present (Classifications (Items)));
1734 end Has_Some_Contract;
1736 ---------------------
1737 -- In_Package_Spec --
1738 ---------------------
1740 function In_Package_Spec (Id : Entity_Id) return Boolean is
1741 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1742 -- Parent of the subprogram's declaration
1745 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1746 end In_Package_Spec;
1748 ------------------------
1749 -- Is_Unit_Subprogram --
1750 ------------------------
1752 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1753 Decl : Node_Id := Parent (Parent (Id));
1755 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1756 Decl := Parent (Decl);
1759 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1760 end Is_Unit_Subprogram;
1762 ------------------------------
1763 -- Maybe_Traversal_Function --
1764 ------------------------------
1766 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
1768 return Ekind (Id) = E_Function
1770 -- Only traversal functions return an anonymous access-to-object
1773 and then Is_Anonymous_Access_Type (Etype (Id));
1774 end Maybe_Traversal_Function;
1776 -- Local declarations
1779 -- Procedure or function entity for the subprogram
1781 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1784 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1786 if Present (Spec_Id) then
1792 -- Only local subprograms without contracts are inlined in GNATprove
1793 -- mode, as these are the subprograms which a user is not interested in
1794 -- analyzing in isolation, but rather in the context of their call. This
1795 -- is a convenient convention, that could be changed for an explicit
1796 -- pragma/aspect one day.
1798 -- In a number of special cases, inlining is not desirable or not
1799 -- possible, see below.
1801 -- Do not inline unit-level subprograms
1803 if Is_Unit_Subprogram (Id) then
1806 -- Do not inline subprograms declared in package specs, because they are
1807 -- not local, i.e. can be called either from anywhere (if declared in
1808 -- visible part) or from the child units (if declared in private part).
1810 elsif In_Package_Spec (Id) then
1813 -- Do not inline subprograms declared in other units. This is important
1814 -- in particular for subprograms defined in the private part of a
1815 -- package spec, when analyzing one of its child packages, as otherwise
1816 -- we issue spurious messages about the impossibility to inline such
1819 elsif not In_Extended_Main_Code_Unit (Id) then
1822 -- Do not inline dispatching operations, as only their static calls
1823 -- can be analyzed in context, and not their dispatching calls.
1825 elsif Is_Dispatching_Operation (Id) then
1828 -- Do not inline subprograms marked No_Return, possibly used for
1829 -- signaling errors, which GNATprove handles specially.
1831 elsif No_Return (Id) then
1834 -- Do not inline subprograms that have a contract on the spec or the
1835 -- body. Use the contract(s) instead in GNATprove. This also prevents
1836 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1838 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1840 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1844 -- Do not inline expression functions, which are directly inlined at the
1847 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1849 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1853 -- Do not inline generic subprogram instances. The visibility rules of
1854 -- generic instances plays badly with inlining.
1856 elsif Is_Generic_Instance (Spec_Id) then
1859 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1860 -- the subprogram body, a similar check is performed after the body
1861 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1863 elsif Present (Spec_Id)
1865 (No (SPARK_Pragma (Spec_Id))
1867 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1871 -- Subprograms in generic instances are currently not inlined, to avoid
1872 -- problems with inlining of standard library subprograms.
1874 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1877 -- Do not inline subprograms and entries defined inside protected types,
1878 -- which typically are not helper subprograms, which also avoids getting
1879 -- spurious messages on calls that cannot be inlined.
1881 elsif Within_Protected_Type (Id) then
1884 -- Do not inline predicate functions (treated specially by GNATprove)
1886 elsif Is_Predicate_Function (Id) then
1889 -- Do not inline subprograms with a parameter of an unconstrained
1890 -- record type if it has discrimiant dependent fields. Indeed, with
1891 -- such parameters, the frontend cannot always ensure type compliance
1892 -- in record component accesses (in particular with records containing
1895 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1898 -- Do not inline subprograms with a formal parameter or return type of
1899 -- a deep type, as in that case inlining might generate code that
1900 -- violates borrow-checking rules of SPARK 3.10 even if the original
1903 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
1906 -- Do not inline subprograms which may be traversal functions. Such
1907 -- inlining introduces temporary variables of named access type for
1908 -- which assignments are move instead of borrow/observe, possibly
1909 -- leading to spurious errors when checking SPARK rules related to
1912 elsif Maybe_Traversal_Function (Id) then
1915 -- Otherwise, this is a subprogram declared inside the private part of a
1916 -- package, or inside a package body, or locally in a subprogram, and it
1917 -- does not have any contract. Inline it.
1922 end Can_Be_Inlined_In_GNATprove_Mode;
1928 procedure Cannot_Inline
1932 Is_Serious : Boolean := False)
1935 -- In GNATprove mode, inlining is the technical means by which the
1936 -- higher-level goal of contextual analysis is reached, so issue
1937 -- messages about failure to apply contextual analysis to a
1938 -- subprogram, rather than failure to inline it.
1941 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1944 Len1 : constant Positive :=
1945 String (String'("cannot inline"))'Length;
1946 Len2
: constant Positive :=
1947 String (String'("info: no contextual analysis of"))'Length;
1949 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1952 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1953 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1954 Msg (Msg'First + Len1 .. Msg'Last);
1955 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1960 pragma Assert (Msg (Msg'Last) = '?
');
1962 -- Legacy front-end inlining model
1964 if not Back_End_Inlining then
1966 -- Do not emit warning if this is a predefined unit which is not
1967 -- the main unit. With validity checks enabled, some predefined
1968 -- subprograms may contain nested subprograms and become ineligible
1971 if Is_Predefined_Unit (Get_Source_Unit (Subp))
1972 and then not In_Extended_Main_Source_Unit (Subp)
1976 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
1977 -- indicate that the subprogram is not always inlined by setting
1978 -- flag Is_Inlined_Always to False.
1980 elsif GNATprove_Mode then
1981 Set_Is_Inlined_Always (Subp, False);
1983 if Debug_Flag_Underscore_F then
1984 Error_Msg_NE (Msg, N, Subp);
1987 elsif Has_Pragma_Inline_Always (Subp) then
1989 -- Remove last character (question mark) to make this into an
1990 -- error, because the Inline_Always pragma cannot be obeyed.
1992 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1994 elsif Ineffective_Inline_Warnings then
1995 Error_Msg_NE (Msg & "p?", N, Subp);
1998 -- New semantics relying on back-end inlining
2000 elsif Is_Serious then
2002 -- Remove last character (question mark) to make this into an error.
2004 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2006 -- In GNATprove mode, issue a warning when -gnatd_f is set, and
2007 -- indicate that the subprogram is not always inlined by setting
2008 -- flag Is_Inlined_Always to False.
2010 elsif GNATprove_Mode then
2011 Set_Is_Inlined_Always (Subp, False);
2013 if Debug_Flag_Underscore_F then
2014 Error_Msg_NE (Msg, N, Subp);
2019 -- Do not emit warning if this is a predefined unit which is not
2020 -- the main unit. This behavior is currently provided for backward
2021 -- compatibility but it will be removed when we enforce the
2022 -- strictness of the new rules.
2024 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2025 and then not In_Extended_Main_Source_Unit (Subp)
2029 elsif Has_Pragma_Inline_Always (Subp) then
2031 -- Emit a warning if this is a call to a runtime subprogram
2032 -- which is located inside a generic. Previously this call
2033 -- was silently skipped.
2035 if Is_Generic_Instance (Subp) then
2037 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
2039 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
2040 Set_Is_Inlined (Subp, False);
2041 Error_Msg_NE (Msg & "p?", N, Subp);
2047 -- Remove last character (question mark) to make this into an
2048 -- error, because the Inline_Always pragma cannot be obeyed.
2050 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2053 Set_Is_Inlined (Subp, False);
2055 if Ineffective_Inline_Warnings then
2056 Error_Msg_NE (Msg & "p?", N, Subp);
2062 --------------------------------------------
2063 -- Check_And_Split_Unconstrained_Function --
2064 --------------------------------------------
2066 procedure Check_And_Split_Unconstrained_Function
2068 Spec_Id : Entity_Id;
2069 Body_Id : Entity_Id)
2071 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
2072 -- Use generic machinery to build an unexpanded body for the subprogram.
2073 -- This body is subsequently used for inline expansions at call sites.
2075 procedure Build_Return_Object_Formal
2079 -- Create a formal parameter for return object declaration Obj_Decl of
2080 -- an extended return statement and add it to list Formals.
2082 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
2083 -- Return true if we generate code for the function body N, the function
2084 -- body N has no local declarations and its unique statement is a single
2085 -- extended return statement with a handled statements sequence.
2087 procedure Copy_Formals
2089 Subp_Id : Entity_Id;
2091 -- Create new formal parameters from the formal parameters of subprogram
2092 -- Subp_Id and add them to list Formals.
2094 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
2095 -- Create a copy of return object declaration Obj_Decl of an extended
2096 -- return statement.
2098 procedure Split_Unconstrained_Function
2100 Spec_Id : Entity_Id);
2101 -- N is an inlined function body that returns an unconstrained type and
2102 -- has a single extended return statement. Split N in two subprograms:
2103 -- a procedure P' and a
function F
'. The formals of P' duplicate the
2104 -- formals of N plus an extra formal which is used to return a value;
2105 -- its body is composed by the declarations and list of statements
2106 -- of the extended return statement of N.
2108 --------------------------
2109 -- Build_Body_To_Inline --
2110 --------------------------
2112 procedure Build_Body_To_Inline
(N
: Node_Id
; Spec_Id
: Entity_Id
) is
2113 procedure Generate_Subprogram_Body
2115 Body_To_Inline
: out Node_Id
);
2116 -- Generate a parameterless duplicate of subprogram body N. Note that
2117 -- occurrences of pragmas referencing the formals are removed since
2118 -- they have no meaning when the body is inlined and the formals are
2119 -- rewritten (the analysis of the non-inlined body will handle these
2120 -- pragmas). A new internal name is associated with Body_To_Inline.
2122 ------------------------------
2123 -- Generate_Subprogram_Body --
2124 ------------------------------
2126 procedure Generate_Subprogram_Body
2128 Body_To_Inline
: out Node_Id
)
2131 -- Within an instance, the body to inline must be treated as a
2132 -- nested generic so that proper global references are preserved.
2134 -- Note that we do not do this at the library level, because it
2135 -- is not needed, and furthermore this causes trouble if front
2136 -- end inlining is activated (-gnatN).
2139 and then Scope
(Current_Scope
) /= Standard_Standard
2142 Copy_Generic_Node
(N
, Empty
, Instantiating
=> True);
2144 -- ??? Shouldn't this use New_Copy_Tree? What about global
2145 -- references captured in the body to inline?
2147 Body_To_Inline
:= Copy_Separate_Tree
(N
);
2150 -- Remove aspects/pragmas that have no meaning in an inlined body
2152 Remove_Aspects_And_Pragmas
(Body_To_Inline
);
2154 -- We need to capture references to the formals in order
2155 -- to substitute the actuals at the point of inlining, i.e.
2156 -- instantiation. To treat the formals as globals to the body to
2157 -- inline, we nest it within a dummy parameterless subprogram,
2158 -- declared within the real one.
2160 Set_Parameter_Specifications
2161 (Specification
(Body_To_Inline
), No_List
);
2163 -- A new internal name is associated with Body_To_Inline to avoid
2164 -- conflicts when the non-inlined body N is analyzed.
2166 Set_Defining_Unit_Name
(Specification
(Body_To_Inline
),
2167 Make_Defining_Identifier
(Sloc
(N
), New_Internal_Name
('P')));
2168 Set_Corresponding_Spec
(Body_To_Inline
, Empty
);
2169 end Generate_Subprogram_Body
;
2173 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2174 Original_Body
: Node_Id
;
2175 Body_To_Analyze
: Node_Id
;
2177 -- Start of processing for Build_Body_To_Inline
2180 pragma Assert
(Current_Scope
= Spec_Id
);
2182 -- Within an instance, the body to inline must be treated as a nested
2183 -- generic, so that the proper global references are preserved. We
2184 -- do not do this at the library level, because it is not needed, and
2185 -- furthermore this causes trouble if front-end inlining is activated
2189 and then Scope
(Current_Scope
) /= Standard_Standard
2191 Save_Env
(Scope
(Current_Scope
), Scope
(Current_Scope
));
2194 -- Capture references to formals in order to substitute the actuals
2195 -- at the point of inlining or instantiation. To treat the formals
2196 -- as globals to the body to inline, nest the body within a dummy
2197 -- parameterless subprogram, declared within the real one.
2199 Generate_Subprogram_Body
(N
, Original_Body
);
2201 Copy_Generic_Node
(Original_Body
, Empty
, Instantiating
=> False);
2203 -- Set return type of function, which is also global and does not
2204 -- need to be resolved.
2206 if Ekind
(Spec_Id
) = E_Function
then
2207 Set_Result_Definition
(Specification
(Body_To_Analyze
),
2208 New_Occurrence_Of
(Etype
(Spec_Id
), Sloc
(N
)));
2211 if No
(Declarations
(N
)) then
2212 Set_Declarations
(N
, New_List
(Body_To_Analyze
));
2214 Append_To
(Declarations
(N
), Body_To_Analyze
);
2217 Preanalyze
(Body_To_Analyze
);
2219 Push_Scope
(Defining_Entity
(Body_To_Analyze
));
2220 Save_Global_References
(Original_Body
);
2222 Remove
(Body_To_Analyze
);
2224 -- Restore environment if previously saved
2227 and then Scope
(Current_Scope
) /= Standard_Standard
2232 pragma Assert
(No
(Body_To_Inline
(Decl
)));
2233 Set_Body_To_Inline
(Decl
, Original_Body
);
2234 Set_Ekind
(Defining_Entity
(Original_Body
), Ekind
(Spec_Id
));
2235 end Build_Body_To_Inline
;
2237 --------------------------------
2238 -- Build_Return_Object_Formal --
2239 --------------------------------
2241 procedure Build_Return_Object_Formal
2246 Obj_Def
: constant Node_Id
:= Object_Definition
(Obj_Decl
);
2247 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2251 -- Build the type definition of the formal parameter. The use of
2252 -- New_Copy_Tree ensures that global references preserved in the
2253 -- case of generics.
2255 if Is_Entity_Name
(Obj_Def
) then
2256 Typ_Def
:= New_Copy_Tree
(Obj_Def
);
2258 Typ_Def
:= New_Copy_Tree
(Subtype_Mark
(Obj_Def
));
2263 -- Obj_Id : [out] Typ_Def
2265 -- Mode OUT should not be used when the return object is declared as
2266 -- a constant. Check the definition of the object declaration because
2267 -- the object has not been analyzed yet.
2270 Make_Parameter_Specification
(Loc
,
2271 Defining_Identifier
=>
2272 Make_Defining_Identifier
(Loc
, Chars
(Obj_Id
)),
2273 In_Present
=> False,
2274 Out_Present
=> not Constant_Present
(Obj_Decl
),
2275 Null_Exclusion_Present
=> False,
2276 Parameter_Type
=> Typ_Def
));
2277 end Build_Return_Object_Formal
;
2279 --------------------------------------
2280 -- Can_Split_Unconstrained_Function --
2281 --------------------------------------
2283 function Can_Split_Unconstrained_Function
(N
: Node_Id
) return Boolean is
2284 Stmt
: constant Node_Id
:=
2285 First
(Statements
(Handled_Statement_Sequence
(N
)));
2289 -- No user defined declarations allowed in the function except inside
2290 -- the unique return statement; implicit labels are the only allowed
2293 Decl
:= First
(Declarations
(N
));
2294 while Present
(Decl
) loop
2295 if Nkind
(Decl
) /= N_Implicit_Label_Declaration
then
2302 -- We only split the inlined function when we are generating the code
2303 -- of its body; otherwise we leave duplicated split subprograms in
2304 -- the tree which (if referenced) generate wrong references at link
2307 return In_Extended_Main_Code_Unit
(N
)
2308 and then Present
(Stmt
)
2309 and then Nkind
(Stmt
) = N_Extended_Return_Statement
2310 and then No
(Next
(Stmt
))
2311 and then Present
(Handled_Statement_Sequence
(Stmt
));
2312 end Can_Split_Unconstrained_Function
;
2318 procedure Copy_Formals
2320 Subp_Id
: Entity_Id
;
2327 Formal
:= First_Formal
(Subp_Id
);
2328 while Present
(Formal
) loop
2329 Spec
:= Parent
(Formal
);
2331 -- Create an exact copy of the formal parameter. The use of
2332 -- New_Copy_Tree ensures that global references are preserved
2333 -- in case of generics.
2336 Make_Parameter_Specification
(Loc
,
2337 Defining_Identifier
=>
2338 Make_Defining_Identifier
(Sloc
(Formal
), Chars
(Formal
)),
2339 In_Present
=> In_Present
(Spec
),
2340 Out_Present
=> Out_Present
(Spec
),
2341 Null_Exclusion_Present
=> Null_Exclusion_Present
(Spec
),
2343 New_Copy_Tree
(Parameter_Type
(Spec
)),
2344 Expression
=> New_Copy_Tree
(Expression
(Spec
))));
2346 Next_Formal
(Formal
);
2350 ------------------------
2351 -- Copy_Return_Object --
2352 ------------------------
2354 function Copy_Return_Object
(Obj_Decl
: Node_Id
) return Node_Id
is
2355 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2358 -- The use of New_Copy_Tree ensures that global references are
2359 -- preserved in case of generics.
2362 Make_Object_Declaration
(Sloc
(Obj_Decl
),
2363 Defining_Identifier
=>
2364 Make_Defining_Identifier
(Sloc
(Obj_Id
), Chars
(Obj_Id
)),
2365 Aliased_Present
=> Aliased_Present
(Obj_Decl
),
2366 Constant_Present
=> Constant_Present
(Obj_Decl
),
2367 Null_Exclusion_Present
=> Null_Exclusion_Present
(Obj_Decl
),
2368 Object_Definition
=>
2369 New_Copy_Tree
(Object_Definition
(Obj_Decl
)),
2370 Expression
=> New_Copy_Tree
(Expression
(Obj_Decl
)));
2371 end Copy_Return_Object
;
2373 ----------------------------------
2374 -- Split_Unconstrained_Function --
2375 ----------------------------------
2377 procedure Split_Unconstrained_Function
2379 Spec_Id
: Entity_Id
)
2381 Loc
: constant Source_Ptr
:= Sloc
(N
);
2382 Ret_Stmt
: constant Node_Id
:=
2383 First
(Statements
(Handled_Statement_Sequence
(N
)));
2384 Ret_Obj
: constant Node_Id
:=
2385 First
(Return_Object_Declarations
(Ret_Stmt
));
2387 procedure Build_Procedure
2388 (Proc_Id
: out Entity_Id
;
2389 Decl_List
: out List_Id
);
2390 -- Build a procedure containing the statements found in the extended
2391 -- return statement of the unconstrained function body N.
2393 ---------------------
2394 -- Build_Procedure --
2395 ---------------------
2397 procedure Build_Procedure
2398 (Proc_Id
: out Entity_Id
;
2399 Decl_List
: out List_Id
)
2401 Formals
: constant List_Id
:= New_List
;
2402 Subp_Name
: constant Name_Id
:= New_Internal_Name
('F');
2404 Body_Decls
: List_Id
:= No_List
;
2406 Proc_Body
: Node_Id
;
2407 Proc_Spec
: Node_Id
;
2410 -- Create formal parameters for the return object and all formals
2411 -- of the unconstrained function in order to pass their values to
2414 Build_Return_Object_Formal
2416 Obj_Decl
=> Ret_Obj
,
2417 Formals
=> Formals
);
2422 Formals
=> Formals
);
2424 Proc_Id
:= Make_Defining_Identifier
(Loc
, Chars
=> Subp_Name
);
2427 Make_Procedure_Specification
(Loc
,
2428 Defining_Unit_Name
=> Proc_Id
,
2429 Parameter_Specifications
=> Formals
);
2431 Decl_List
:= New_List
;
2433 Append_To
(Decl_List
,
2434 Make_Subprogram_Declaration
(Loc
, Proc_Spec
));
2436 -- Can_Convert_Unconstrained_Function checked that the function
2437 -- has no local declarations except implicit label declarations.
2438 -- Copy these declarations to the built procedure.
2440 if Present
(Declarations
(N
)) then
2441 Body_Decls
:= New_List
;
2443 Decl
:= First
(Declarations
(N
));
2444 while Present
(Decl
) loop
2445 pragma Assert
(Nkind
(Decl
) = N_Implicit_Label_Declaration
);
2447 Append_To
(Body_Decls
,
2448 Make_Implicit_Label_Declaration
(Loc
,
2449 Make_Defining_Identifier
(Loc
,
2450 Chars
=> Chars
(Defining_Identifier
(Decl
))),
2451 Label_Construct
=> Empty
));
2457 pragma Assert
(Present
(Handled_Statement_Sequence
(Ret_Stmt
)));
2460 Make_Subprogram_Body
(Loc
,
2461 Specification
=> Copy_Subprogram_Spec
(Proc_Spec
),
2462 Declarations
=> Body_Decls
,
2463 Handled_Statement_Sequence
=>
2464 New_Copy_Tree
(Handled_Statement_Sequence
(Ret_Stmt
)));
2466 Set_Defining_Unit_Name
(Specification
(Proc_Body
),
2467 Make_Defining_Identifier
(Loc
, Subp_Name
));
2469 Append_To
(Decl_List
, Proc_Body
);
2470 end Build_Procedure
;
2474 New_Obj
: constant Node_Id
:= Copy_Return_Object
(Ret_Obj
);
2476 Proc_Call
: Node_Id
;
2477 Proc_Id
: Entity_Id
;
2479 -- Start of processing for Split_Unconstrained_Function
2482 -- Build the associated procedure, analyze it and insert it before
2483 -- the function body N.
2486 Scope
: constant Entity_Id
:= Current_Scope
;
2487 Decl_List
: List_Id
;
2490 Build_Procedure
(Proc_Id
, Decl_List
);
2491 Insert_Actions
(N
, Decl_List
);
2492 Set_Is_Inlined
(Proc_Id
);
2496 -- Build the call to the generated procedure
2499 Actual_List
: constant List_Id
:= New_List
;
2503 Append_To
(Actual_List
,
2504 New_Occurrence_Of
(Defining_Identifier
(New_Obj
), Loc
));
2506 Formal
:= First_Formal
(Spec_Id
);
2507 while Present
(Formal
) loop
2508 Append_To
(Actual_List
, New_Occurrence_Of
(Formal
, Loc
));
2510 -- Avoid spurious warning on unreferenced formals
2512 Set_Referenced
(Formal
);
2513 Next_Formal
(Formal
);
2517 Make_Procedure_Call_Statement
(Loc
,
2518 Name
=> New_Occurrence_Of
(Proc_Id
, Loc
),
2519 Parameter_Associations
=> Actual_List
);
2527 -- Proc (New_Obj, ...);
2532 Make_Block_Statement
(Loc
,
2533 Declarations
=> New_List
(New_Obj
),
2534 Handled_Statement_Sequence
=>
2535 Make_Handled_Sequence_Of_Statements
(Loc
,
2536 Statements
=> New_List
(
2540 Make_Simple_Return_Statement
(Loc
,
2543 (Defining_Identifier
(New_Obj
), Loc
)))));
2545 Rewrite
(Ret_Stmt
, Blk_Stmt
);
2546 end Split_Unconstrained_Function
;
2550 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
2552 -- Start of processing for Check_And_Split_Unconstrained_Function
2555 pragma Assert
(Back_End_Inlining
2556 and then Ekind
(Spec_Id
) = E_Function
2557 and then Returns_Unconstrained_Type
(Spec_Id
)
2558 and then Comes_From_Source
(Body_Id
)
2559 and then (Has_Pragma_Inline_Always
(Spec_Id
)
2560 or else Optimization_Level
> 0));
2562 -- This routine must not be used in GNATprove mode since GNATprove
2563 -- relies on frontend inlining
2565 pragma Assert
(not GNATprove_Mode
);
2567 -- No need to split the function if we cannot generate the code
2569 if Serious_Errors_Detected
/= 0 then
2573 -- No action needed in stubs since the attribute Body_To_Inline
2576 if Nkind
(Decl
) = N_Subprogram_Body_Stub
then
2579 -- Cannot build the body to inline if the attribute is already set.
2580 -- This attribute may have been set if this is a subprogram renaming
2581 -- declarations (see Freeze.Build_Renamed_Body).
2583 elsif Present
(Body_To_Inline
(Decl
)) then
2586 -- Do not generate a body to inline for protected functions, because the
2587 -- transformation generates a call to a protected procedure, causing
2588 -- spurious errors. We don't inline protected operations anyway, so
2589 -- this is no loss. We might as well ignore intrinsics and foreign
2590 -- conventions as well -- just allow Ada conventions.
2592 elsif not (Convention
(Spec_Id
) = Convention_Ada
2593 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Copy
2594 or else Convention
(Spec_Id
) = Convention_Ada_Pass_By_Reference
)
2598 -- Check excluded declarations
2600 elsif Present
(Declarations
(N
))
2601 and then Has_Excluded_Declaration
(Spec_Id
, Declarations
(N
))
2605 -- Check excluded statements. There is no need to protect us against
2606 -- exception handlers since they are supported by the GCC backend.
2608 elsif Present
(Handled_Statement_Sequence
(N
))
2609 and then Has_Excluded_Statement
2610 (Spec_Id
, Statements
(Handled_Statement_Sequence
(N
)))
2615 -- Build the body to inline only if really needed
2617 if Can_Split_Unconstrained_Function
(N
) then
2618 Split_Unconstrained_Function
(N
, Spec_Id
);
2619 Build_Body_To_Inline
(N
, Spec_Id
);
2620 Set_Is_Inlined
(Spec_Id
);
2622 end Check_And_Split_Unconstrained_Function
;
2624 -------------------------------------
2625 -- Check_Package_Body_For_Inlining --
2626 -------------------------------------
2628 procedure Check_Package_Body_For_Inlining
(N
: Node_Id
; P
: Entity_Id
) is
2629 Bname
: Unit_Name_Type
;
2634 -- Legacy implementation (relying on frontend inlining)
2636 if not Back_End_Inlining
2637 and then Is_Compilation_Unit
(P
)
2638 and then not Is_Generic_Instance
(P
)
2640 Bname
:= Get_Body_Name
(Get_Unit_Name
(Unit
(N
)));
2642 E
:= First_Entity
(P
);
2643 while Present
(E
) loop
2644 if Has_Pragma_Inline_Always
(E
)
2645 or else (Has_Pragma_Inline
(E
) and Front_End_Inlining
)
2647 if not Is_Loaded
(Bname
) then
2648 Load_Needed_Body
(N
, OK
);
2652 -- Check we are not trying to inline a parent whose body
2653 -- depends on a child, when we are compiling the body of
2654 -- the child. Otherwise we have a potential elaboration
2655 -- circularity with inlined subprograms and with
2656 -- Taft-Amendment types.
2659 Comp
: Node_Id
; -- Body just compiled
2660 Child_Spec
: Entity_Id
; -- Spec of main unit
2661 Ent
: Entity_Id
; -- For iteration
2662 With_Clause
: Node_Id
; -- Context of body.
2665 if Nkind
(Unit
(Cunit
(Main_Unit
))) = N_Package_Body
2666 and then Present
(Body_Entity
(P
))
2670 ((Unit
(Library_Unit
(Cunit
(Main_Unit
)))));
2673 Parent
(Unit_Declaration_Node
(Body_Entity
(P
)));
2675 -- Check whether the context of the body just
2676 -- compiled includes a child of itself, and that
2677 -- child is the spec of the main compilation.
2679 With_Clause
:= First
(Context_Items
(Comp
));
2680 while Present
(With_Clause
) loop
2681 if Nkind
(With_Clause
) = N_With_Clause
2683 Scope
(Entity
(Name
(With_Clause
))) = P
2685 Entity
(Name
(With_Clause
)) = Child_Spec
2687 Error_Msg_Node_2
:= Child_Spec
;
2689 ("body of & depends on child unit&??",
2692 ("\subprograms in body cannot be inlined??",
2695 -- Disable further inlining from this unit,
2696 -- and keep Taft-amendment types incomplete.
2698 Ent
:= First_Entity
(P
);
2699 while Present
(Ent
) loop
2701 and then Has_Completion_In_Body
(Ent
)
2703 Set_Full_View
(Ent
, Empty
);
2705 elsif Is_Subprogram
(Ent
) then
2706 Set_Is_Inlined
(Ent
, False);
2720 elsif Ineffective_Inline_Warnings
then
2721 Error_Msg_Unit_1
:= Bname
;
2723 ("unable to inline subprograms defined in $??", P
);
2724 Error_Msg_N
("\body not found??", P
);
2735 end Check_Package_Body_For_Inlining
;
2737 --------------------
2738 -- Cleanup_Scopes --
2739 --------------------
2741 procedure Cleanup_Scopes
is
2747 Elmt
:= First_Elmt
(To_Clean
);
2748 while Present
(Elmt
) loop
2749 Scop
:= Node
(Elmt
);
2751 if Ekind
(Scop
) = E_Entry
then
2752 Scop
:= Protected_Body_Subprogram
(Scop
);
2754 elsif Is_Subprogram
(Scop
)
2755 and then Is_Protected_Type
(Scope
(Scop
))
2756 and then Present
(Protected_Body_Subprogram
(Scop
))
2758 -- If a protected operation contains an instance, its cleanup
2759 -- operations have been delayed, and the subprogram has been
2760 -- rewritten in the expansion of the enclosing protected body. It
2761 -- is the corresponding subprogram that may require the cleanup
2762 -- operations, so propagate the information that triggers cleanup
2766 (Protected_Body_Subprogram
(Scop
),
2767 Uses_Sec_Stack
(Scop
));
2769 Scop
:= Protected_Body_Subprogram
(Scop
);
2772 if Ekind
(Scop
) = E_Block
then
2773 Decl
:= Parent
(Block_Node
(Scop
));
2776 Decl
:= Unit_Declaration_Node
(Scop
);
2778 if Nkind_In
(Decl
, N_Subprogram_Declaration
,
2779 N_Task_Type_Declaration
,
2780 N_Subprogram_Body_Stub
)
2782 Decl
:= Unit_Declaration_Node
(Corresponding_Body
(Decl
));
2787 Expand_Cleanup_Actions
(Decl
);
2790 Elmt
:= Next_Elmt
(Elmt
);
2794 -------------------------
2795 -- Expand_Inlined_Call --
2796 -------------------------
2798 procedure Expand_Inlined_Call
2801 Orig_Subp
: Entity_Id
)
2803 Decls
: constant List_Id
:= New_List
;
2804 Is_Predef
: constant Boolean :=
2805 Is_Predefined_Unit
(Get_Source_Unit
(Subp
));
2806 Loc
: constant Source_Ptr
:= Sloc
(N
);
2807 Orig_Bod
: constant Node_Id
:=
2808 Body_To_Inline
(Unit_Declaration_Node
(Subp
));
2810 Uses_Back_End
: constant Boolean :=
2811 Back_End_Inlining
and then Optimization_Level
> 0;
2812 -- The back-end expansion is used if the target supports back-end
2813 -- inlining and some level of optimixation is required; otherwise
2814 -- the inlining takes place fully as a tree expansion.
2818 Exit_Lab
: Entity_Id
:= Empty
;
2821 Lab_Decl
: Node_Id
:= Empty
;
2825 Ret_Type
: Entity_Id
;
2827 Temp_Typ
: Entity_Id
;
2830 Is_Unc_Decl
: Boolean;
2831 -- If the type returned by the function is unconstrained and the call
2832 -- can be inlined, special processing is required.
2834 Return_Object
: Entity_Id
:= Empty
;
2835 -- Entity in declaration in an extended_return_statement
2837 Targ
: Node_Id
:= Empty
;
2838 -- The target of the call. If context is an assignment statement then
2839 -- this is the left-hand side of the assignment, else it is a temporary
2840 -- to which the return value is assigned prior to rewriting the call.
2842 Targ1
: Node_Id
:= Empty
;
2843 -- A separate target used when the return type is unconstrained
2845 procedure Declare_Postconditions_Result
;
2846 -- When generating C code, declare _Result, which may be used in the
2847 -- inlined _Postconditions procedure to verify the return value.
2849 procedure Make_Exit_Label
;
2850 -- Build declaration for exit label to be used in Return statements,
2851 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2852 -- declaration). Does nothing if Exit_Lab already set.
2854 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
);
2855 -- When compiling for CCG and performing front-end inlining, replace
2856 -- loop names and references to them so that they do not conflict with
2857 -- homographs in the current subprogram.
2859 function Process_Formals
(N
: Node_Id
) return Traverse_Result
;
2860 -- Replace occurrence of a formal with the corresponding actual, or the
2861 -- thunk generated for it. Replace a return statement with an assignment
2862 -- to the target of the call, with appropriate conversions if needed.
2864 function Process_Formals_In_Aspects
(N
: Node_Id
) return Traverse_Result
;
2865 -- Because aspects are linked indirectly to the rest of the tree,
2866 -- replacement of formals appearing in aspect specifications must
2867 -- be performed in a separate pass, using an instantiation of the
2868 -- previous subprogram over aspect specifications reachable from N.
2870 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
;
2871 -- If the call being expanded is that of an internal subprogram, set the
2872 -- sloc of the generated block to that of the call itself, so that the
2873 -- expansion is skipped by the "next" command in gdb. Same processing
2874 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2875 -- Debug_Generated_Code is true, suppress this change to simplify our
2876 -- own development. Same in GNATprove mode, to ensure that warnings and
2877 -- diagnostics point to the proper location.
2879 procedure Reset_Dispatching_Calls
(N
: Node_Id
);
2880 -- In subtree N search for occurrences of dispatching calls that use the
2881 -- Ada 2005 Object.Operation notation and the object is a formal of the
2882 -- inlined subprogram. Reset the entity associated with Operation in all
2883 -- the found occurrences.
2885 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
);
2886 -- If the function body is a single expression, replace call with
2887 -- expression, else insert block appropriately.
2889 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
);
2890 -- If procedure body has no local variables, inline body without
2891 -- creating block, otherwise rewrite call with block.
2893 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean;
2894 -- Determine whether a formal parameter is used only once in Orig_Bod
2896 -----------------------------------
2897 -- Declare_Postconditions_Result --
2898 -----------------------------------
2900 procedure Declare_Postconditions_Result
is
2901 Enclosing_Subp
: constant Entity_Id
:= Scope
(Subp
);
2906 and then Is_Subprogram
(Enclosing_Subp
)
2907 and then Present
(Postconditions_Proc
(Enclosing_Subp
)));
2909 if Ekind
(Enclosing_Subp
) = E_Function
then
2910 if Nkind
(First
(Parameter_Associations
(N
))) in
2911 N_Numeric_Or_String_Literal
2913 Append_To
(Declarations
(Blk
),
2914 Make_Object_Declaration
(Loc
,
2915 Defining_Identifier
=>
2916 Make_Defining_Identifier
(Loc
, Name_uResult
),
2917 Constant_Present
=> True,
2918 Object_Definition
=>
2919 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2921 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2923 Append_To
(Declarations
(Blk
),
2924 Make_Object_Renaming_Declaration
(Loc
,
2925 Defining_Identifier
=>
2926 Make_Defining_Identifier
(Loc
, Name_uResult
),
2928 New_Occurrence_Of
(Etype
(Enclosing_Subp
), Loc
),
2930 New_Copy_Tree
(First
(Parameter_Associations
(N
)))));
2933 end Declare_Postconditions_Result
;
2935 ---------------------
2936 -- Make_Exit_Label --
2937 ---------------------
2939 procedure Make_Exit_Label
is
2940 Lab_Ent
: Entity_Id
;
2942 if No
(Exit_Lab
) then
2943 Lab_Ent
:= Make_Temporary
(Loc
, 'L');
2944 Lab_Id
:= New_Occurrence_Of
(Lab_Ent
, Loc
);
2945 Exit_Lab
:= Make_Label
(Loc
, Lab_Id
);
2947 Make_Implicit_Label_Declaration
(Loc
,
2948 Defining_Identifier
=> Lab_Ent
,
2949 Label_Construct
=> Exit_Lab
);
2951 end Make_Exit_Label
;
2953 -----------------------------
2954 -- Make_Loop_Labels_Unique --
2955 -----------------------------
2957 procedure Make_Loop_Labels_Unique
(HSS
: Node_Id
) is
2958 function Process_Loop
(N
: Node_Id
) return Traverse_Result
;
2964 function Process_Loop
(N
: Node_Id
) return Traverse_Result
is
2968 if Nkind
(N
) = N_Loop_Statement
2969 and then Present
(Identifier
(N
))
2971 -- Create new external name for loop and update the
2972 -- corresponding entity.
2974 Id
:= Entity
(Identifier
(N
));
2975 Set_Chars
(Id
, New_External_Name
(Chars
(Id
), 'L', -1));
2976 Set_Chars
(Identifier
(N
), Chars
(Id
));
2978 elsif Nkind
(N
) = N_Exit_Statement
2979 and then Present
(Name
(N
))
2981 -- The exit statement must name an enclosing loop, whose name
2982 -- has already been updated.
2984 Set_Chars
(Name
(N
), Chars
(Entity
(Name
(N
))));
2990 procedure Update_Loop_Names
is new Traverse_Proc
(Process_Loop
);
2996 -- Start of processing for Make_Loop_Labels_Unique
2999 if Modify_Tree_For_C
then
3000 Stmt
:= First
(Statements
(HSS
));
3001 while Present
(Stmt
) loop
3002 Update_Loop_Names
(Stmt
);
3006 end Make_Loop_Labels_Unique
;
3008 ---------------------
3009 -- Process_Formals --
3010 ---------------------
3012 function Process_Formals
(N
: Node_Id
) return Traverse_Result
is
3018 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
3021 if Is_Formal
(E
) and then Scope
(E
) = Subp
then
3022 A
:= Renamed_Object
(E
);
3024 -- Rewrite the occurrence of the formal into an occurrence of
3025 -- the actual. Also establish visibility on the proper view of
3026 -- the actual's subtype for the body's context (if the actual's
3027 -- subtype is private at the call point but its full view is
3028 -- visible to the body, then the inlined tree here must be
3029 -- analyzed with the full view).
3031 if Is_Entity_Name
(A
) then
3032 Rewrite
(N
, New_Occurrence_Of
(Entity
(A
), Sloc
(N
)));
3033 Check_Private_View
(N
);
3035 elsif Nkind
(A
) = N_Defining_Identifier
then
3036 Rewrite
(N
, New_Occurrence_Of
(A
, Sloc
(N
)));
3037 Check_Private_View
(N
);
3042 Rewrite
(N
, New_Copy
(A
));
3048 elsif Is_Entity_Name
(N
)
3049 and then Present
(Return_Object
)
3050 and then Chars
(N
) = Chars
(Return_Object
)
3052 -- Occurrence within an extended return statement. The return
3053 -- object is local to the body been inlined, and thus the generic
3054 -- copy is not analyzed yet, so we match by name, and replace it
3055 -- with target of call.
3057 if Nkind
(Targ
) = N_Defining_Identifier
then
3058 Rewrite
(N
, New_Occurrence_Of
(Targ
, Loc
));
3060 Rewrite
(N
, New_Copy_Tree
(Targ
));
3065 elsif Nkind
(N
) = N_Simple_Return_Statement
then
3066 if No
(Expression
(N
)) then
3067 Num_Ret
:= Num_Ret
+ 1;
3070 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3073 if Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
3074 and then Nkind
(Parent
(Parent
(N
))) = N_Subprogram_Body
3076 -- Function body is a single expression. No need for
3082 Num_Ret
:= Num_Ret
+ 1;
3086 -- Because of the presence of private types, the views of the
3087 -- expression and the context may be different, so place
3088 -- a type conversion to the context type to avoid spurious
3089 -- errors, e.g. when the expression is a numeric literal and
3090 -- the context is private. If the expression is an aggregate,
3091 -- use a qualified expression, because an aggregate is not a
3092 -- legal argument of a conversion. Ditto for numeric, character
3093 -- and string literals, and attributes that yield a universal
3094 -- type, because those must be resolved to a specific type.
3096 if Nkind_In
(Expression
(N
), N_Aggregate
,
3097 N_Character_Literal
,
3100 or else Yields_Universal_Type
(Expression
(N
))
3103 Make_Qualified_Expression
(Sloc
(N
),
3104 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3105 Expression
=> Relocate_Node
(Expression
(N
)));
3107 -- Use an unchecked type conversion between access types, for
3108 -- which a type conversion would not always be valid, as no
3109 -- check may result from the conversion.
3111 elsif Is_Access_Type
(Ret_Type
) then
3113 Unchecked_Convert_To
3114 (Ret_Type
, Relocate_Node
(Expression
(N
)));
3116 -- Otherwise use a type conversion, which may trigger a check
3120 Make_Type_Conversion
(Sloc
(N
),
3121 Subtype_Mark
=> New_Occurrence_Of
(Ret_Type
, Sloc
(N
)),
3122 Expression
=> Relocate_Node
(Expression
(N
)));
3125 if Nkind
(Targ
) = N_Defining_Identifier
then
3127 Make_Assignment_Statement
(Loc
,
3128 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3129 Expression
=> Ret
));
3132 Make_Assignment_Statement
(Loc
,
3133 Name
=> New_Copy
(Targ
),
3134 Expression
=> Ret
));
3137 Set_Assignment_OK
(Name
(N
));
3139 if Present
(Exit_Lab
) then
3141 Make_Goto_Statement
(Loc
, Name
=> New_Copy
(Lab_Id
)));
3147 -- An extended return becomes a block whose first statement is the
3148 -- assignment of the initial expression of the return object to the
3149 -- target of the call itself.
3151 elsif Nkind
(N
) = N_Extended_Return_Statement
then
3153 Return_Decl
: constant Entity_Id
:=
3154 First
(Return_Object_Declarations
(N
));
3158 Return_Object
:= Defining_Identifier
(Return_Decl
);
3160 if Present
(Expression
(Return_Decl
)) then
3161 if Nkind
(Targ
) = N_Defining_Identifier
then
3163 Make_Assignment_Statement
(Loc
,
3164 Name
=> New_Occurrence_Of
(Targ
, Loc
),
3165 Expression
=> Expression
(Return_Decl
));
3168 Make_Assignment_Statement
(Loc
,
3169 Name
=> New_Copy
(Targ
),
3170 Expression
=> Expression
(Return_Decl
));
3173 Set_Assignment_OK
(Name
(Assign
));
3175 if No
(Handled_Statement_Sequence
(N
)) then
3176 Set_Handled_Statement_Sequence
(N
,
3177 Make_Handled_Sequence_Of_Statements
(Loc
,
3178 Statements
=> New_List
));
3182 Statements
(Handled_Statement_Sequence
(N
)));
3186 Make_Block_Statement
(Loc
,
3187 Handled_Statement_Sequence
=>
3188 Handled_Statement_Sequence
(N
)));
3193 -- Remove pragma Unreferenced since it may refer to formals that
3194 -- are not visible in the inlined body, and in any case we will
3195 -- not be posting warnings on the inlined body so it is unneeded.
3197 elsif Nkind
(N
) = N_Pragma
3198 and then Pragma_Name
(N
) = Name_Unreferenced
3200 Rewrite
(N
, Make_Null_Statement
(Sloc
(N
)));
3206 end Process_Formals
;
3208 procedure Replace_Formals
is new Traverse_Proc
(Process_Formals
);
3210 --------------------------------
3211 -- Process_Formals_In_Aspects --
3212 --------------------------------
3214 function Process_Formals_In_Aspects
3215 (N
: Node_Id
) return Traverse_Result
3220 if Has_Aspects
(N
) then
3221 A
:= First
(Aspect_Specifications
(N
));
3222 while Present
(A
) loop
3223 Replace_Formals
(Expression
(A
));
3229 end Process_Formals_In_Aspects
;
3231 procedure Replace_Formals_In_Aspects
is
3232 new Traverse_Proc
(Process_Formals_In_Aspects
);
3238 function Process_Sloc
(Nod
: Node_Id
) return Traverse_Result
is
3240 if not Debug_Generated_Code
then
3241 Set_Sloc
(Nod
, Sloc
(N
));
3242 Set_Comes_From_Source
(Nod
, False);
3248 procedure Reset_Slocs
is new Traverse_Proc
(Process_Sloc
);
3250 ------------------------------
3251 -- Reset_Dispatching_Calls --
3252 ------------------------------
3254 procedure Reset_Dispatching_Calls
(N
: Node_Id
) is
3256 function Do_Reset
(N
: Node_Id
) return Traverse_Result
;
3257 -- Comment required ???
3263 function Do_Reset
(N
: Node_Id
) return Traverse_Result
is
3265 if Nkind
(N
) = N_Procedure_Call_Statement
3266 and then Nkind
(Name
(N
)) = N_Selected_Component
3267 and then Nkind
(Prefix
(Name
(N
))) = N_Identifier
3268 and then Is_Formal
(Entity
(Prefix
(Name
(N
))))
3269 and then Is_Dispatching_Operation
3270 (Entity
(Selector_Name
(Name
(N
))))
3272 Set_Entity
(Selector_Name
(Name
(N
)), Empty
);
3278 function Do_Reset_Calls
is new Traverse_Func
(Do_Reset
);
3282 Dummy
: constant Traverse_Result
:= Do_Reset_Calls
(N
);
3283 pragma Unreferenced
(Dummy
);
3285 -- Start of processing for Reset_Dispatching_Calls
3289 end Reset_Dispatching_Calls
;
3291 ---------------------------
3292 -- Rewrite_Function_Call --
3293 ---------------------------
3295 procedure Rewrite_Function_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3296 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3297 Fst
: constant Node_Id
:= First
(Statements
(HSS
));
3300 Make_Loop_Labels_Unique
(HSS
);
3302 -- Optimize simple case: function body is a single return statement,
3303 -- which has been expanded into an assignment.
3305 if Is_Empty_List
(Declarations
(Blk
))
3306 and then Nkind
(Fst
) = N_Assignment_Statement
3307 and then No
(Next
(Fst
))
3309 -- The function call may have been rewritten as the temporary
3310 -- that holds the result of the call, in which case remove the
3311 -- now useless declaration.
3313 if Nkind
(N
) = N_Identifier
3314 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3316 Rewrite
(Parent
(Entity
(N
)), Make_Null_Statement
(Loc
));
3319 Rewrite
(N
, Expression
(Fst
));
3321 elsif Nkind
(N
) = N_Identifier
3322 and then Nkind
(Parent
(Entity
(N
))) = N_Object_Declaration
3324 -- The block assigns the result of the call to the temporary
3326 Insert_After
(Parent
(Entity
(N
)), Blk
);
3328 -- If the context is an assignment, and the left-hand side is free of
3329 -- side-effects, the replacement is also safe.
3330 -- Can this be generalized further???
3332 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3334 (Is_Entity_Name
(Name
(Parent
(N
)))
3336 (Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3337 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
)))))
3340 (Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3341 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))))
3343 -- Replace assignment with the block
3346 Original_Assignment
: constant Node_Id
:= Parent
(N
);
3349 -- Preserve the original assignment node to keep the complete
3350 -- assignment subtree consistent enough for Analyze_Assignment
3351 -- to proceed (specifically, the original Lhs node must still
3352 -- have an assignment statement as its parent).
3354 -- We cannot rely on Original_Node to go back from the block
3355 -- node to the assignment node, because the assignment might
3356 -- already be a rewrite substitution.
3358 Discard_Node
(Relocate_Node
(Original_Assignment
));
3359 Rewrite
(Original_Assignment
, Blk
);
3362 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
then
3364 -- A call to a function which returns an unconstrained type
3365 -- found in the expression initializing an object-declaration is
3366 -- expanded into a procedure call which must be added after the
3367 -- object declaration.
3369 if Is_Unc_Decl
and Back_End_Inlining
then
3370 Insert_Action_After
(Parent
(N
), Blk
);
3372 Set_Expression
(Parent
(N
), Empty
);
3373 Insert_After
(Parent
(N
), Blk
);
3376 elsif Is_Unc
and then not Back_End_Inlining
then
3377 Insert_Before
(Parent
(N
), Blk
);
3379 end Rewrite_Function_Call
;
3381 ----------------------------
3382 -- Rewrite_Procedure_Call --
3383 ----------------------------
3385 procedure Rewrite_Procedure_Call
(N
: Node_Id
; Blk
: Node_Id
) is
3386 HSS
: constant Node_Id
:= Handled_Statement_Sequence
(Blk
);
3389 Make_Loop_Labels_Unique
(HSS
);
3391 -- If there is a transient scope for N, this will be the scope of the
3392 -- actions for N, and the statements in Blk need to be within this
3393 -- scope. For example, they need to have visibility on the constant
3394 -- declarations created for the formals.
3396 -- If N needs no transient scope, and if there are no declarations in
3397 -- the inlined body, we can do a little optimization and insert the
3398 -- statements for the body directly after N, and rewrite N to a
3399 -- null statement, instead of rewriting N into a full-blown block
3402 if not Scope_Is_Transient
3403 and then Is_Empty_List
(Declarations
(Blk
))
3405 Insert_List_After
(N
, Statements
(HSS
));
3406 Rewrite
(N
, Make_Null_Statement
(Loc
));
3410 end Rewrite_Procedure_Call
;
3412 -------------------------
3413 -- Formal_Is_Used_Once --
3414 -------------------------
3416 function Formal_Is_Used_Once
(Formal
: Entity_Id
) return Boolean is
3417 Use_Counter
: Int
:= 0;
3419 function Count_Uses
(N
: Node_Id
) return Traverse_Result
;
3420 -- Traverse the tree and count the uses of the formal parameter.
3421 -- In this case, for optimization purposes, we do not need to
3422 -- continue the traversal once more than one use is encountered.
3428 function Count_Uses
(N
: Node_Id
) return Traverse_Result
is
3430 -- The original node is an identifier
3432 if Nkind
(N
) = N_Identifier
3433 and then Present
(Entity
(N
))
3435 -- Original node's entity points to the one in the copied body
3437 and then Nkind
(Entity
(N
)) = N_Identifier
3438 and then Present
(Entity
(Entity
(N
)))
3440 -- The entity of the copied node is the formal parameter
3442 and then Entity
(Entity
(N
)) = Formal
3444 Use_Counter
:= Use_Counter
+ 1;
3446 if Use_Counter
> 1 then
3448 -- Denote more than one use and abandon the traversal
3459 procedure Count_Formal_Uses
is new Traverse_Proc
(Count_Uses
);
3461 -- Start of processing for Formal_Is_Used_Once
3464 Count_Formal_Uses
(Orig_Bod
);
3465 return Use_Counter
= 1;
3466 end Formal_Is_Used_Once
;
3468 -- Start of processing for Expand_Inlined_Call
3471 -- Initializations for old/new semantics
3473 if not Uses_Back_End
then
3474 Is_Unc
:= Is_Array_Type
(Etype
(Subp
))
3475 and then not Is_Constrained
(Etype
(Subp
));
3476 Is_Unc_Decl
:= False;
3478 Is_Unc
:= Returns_Unconstrained_Type
(Subp
)
3479 and then Optimization_Level
> 0;
3480 Is_Unc_Decl
:= Nkind
(Parent
(N
)) = N_Object_Declaration
3484 -- Check for an illegal attempt to inline a recursive procedure. If the
3485 -- subprogram has parameters this is detected when trying to supply a
3486 -- binding for parameters that already have one. For parameterless
3487 -- subprograms this must be done explicitly.
3489 if In_Open_Scopes
(Subp
) then
3491 ("cannot inline call to recursive subprogram?", N
, Subp
);
3492 Set_Is_Inlined
(Subp
, False);
3495 -- Skip inlining if this is not a true inlining since the attribute
3496 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3497 -- true inlining, Orig_Bod has code rather than being an entity.
3499 elsif Nkind
(Orig_Bod
) in N_Entity
then
3503 if Nkind
(Orig_Bod
) = N_Defining_Identifier
3504 or else Nkind
(Orig_Bod
) = N_Defining_Operator_Symbol
3506 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3507 -- can be replaced with calls to the renamed entity directly, because
3508 -- the subprograms are subtype conformant. If the renamed subprogram
3509 -- is an inherited operation, we must redo the expansion because
3510 -- implicit conversions may be needed. Similarly, if the renamed
3511 -- entity is inlined, expand the call for further optimizations.
3513 Set_Name
(N
, New_Occurrence_Of
(Orig_Bod
, Loc
));
3515 if Present
(Alias
(Orig_Bod
)) or else Is_Inlined
(Orig_Bod
) then
3522 -- Register the call in the list of inlined calls
3524 Append_New_Elmt
(N
, To
=> Inlined_Calls
);
3526 -- Use generic machinery to copy body of inlined subprogram, as if it
3527 -- were an instantiation, resetting source locations appropriately, so
3528 -- that nested inlined calls appear in the main unit.
3530 Save_Env
(Subp
, Empty
);
3531 Set_Copied_Sloc_For_Inlined_Body
(N
, Defining_Entity
(Orig_Bod
));
3535 if not Uses_Back_End
then
3540 Bod
:= Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3542 Make_Block_Statement
(Loc
,
3543 Declarations
=> Declarations
(Bod
),
3544 Handled_Statement_Sequence
=>
3545 Handled_Statement_Sequence
(Bod
));
3547 if No
(Declarations
(Bod
)) then
3548 Set_Declarations
(Blk
, New_List
);
3551 -- When generating C code, declare _Result, which may be used to
3552 -- verify the return value.
3554 if Modify_Tree_For_C
3555 and then Nkind
(N
) = N_Procedure_Call_Statement
3556 and then Chars
(Name
(N
)) = Name_uPostconditions
3558 Declare_Postconditions_Result
;
3561 -- For the unconstrained case, capture the name of the local
3562 -- variable that holds the result. This must be the first
3563 -- declaration in the block, because its bounds cannot depend
3564 -- on local variables. Otherwise there is no way to declare the
3565 -- result outside of the block. Needless to say, in general the
3566 -- bounds will depend on the actuals in the call.
3568 -- If the context is an assignment statement, as is the case
3569 -- for the expansion of an extended return, the left-hand side
3570 -- provides bounds even if the return type is unconstrained.
3574 First_Decl
: Node_Id
;
3577 First_Decl
:= First
(Declarations
(Blk
));
3579 -- If the body is a single extended return statement,the
3580 -- resulting block is a nested block.
3582 if No
(First_Decl
) then
3584 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
3586 if Nkind
(First_Decl
) = N_Block_Statement
then
3587 First_Decl
:= First
(Declarations
(First_Decl
));
3591 -- No front-end inlining possible
3593 if Nkind
(First_Decl
) /= N_Object_Declaration
then
3597 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
3598 Targ1
:= Defining_Identifier
(First_Decl
);
3600 Targ1
:= Name
(Parent
(N
));
3617 Copy_Generic_Node
(Orig_Bod
, Empty
, Instantiating
=> True);
3619 Make_Block_Statement
(Loc
,
3620 Declarations
=> Declarations
(Bod
),
3621 Handled_Statement_Sequence
=>
3622 Handled_Statement_Sequence
(Bod
));
3624 -- Inline a call to a function that returns an unconstrained type.
3625 -- The semantic analyzer checked that frontend-inlined functions
3626 -- returning unconstrained types have no declarations and have
3627 -- a single extended return statement. As part of its processing
3628 -- the function was split into two subprograms: a procedure P' and
3629 -- a function F' that has a block with a call to procedure P' (see
3630 -- Split_Unconstrained_Function).
3636 (Statements
(Handled_Statement_Sequence
(Orig_Bod
)))) =
3640 Blk_Stmt
: constant Node_Id
:=
3641 First
(Statements
(Handled_Statement_Sequence
(Orig_Bod
)));
3642 First_Stmt
: constant Node_Id
:=
3643 First
(Statements
(Handled_Statement_Sequence
(Blk_Stmt
)));
3644 Second_Stmt
: constant Node_Id
:= Next
(First_Stmt
);
3648 (Nkind
(First_Stmt
) = N_Procedure_Call_Statement
3649 and then Nkind
(Second_Stmt
) = N_Simple_Return_Statement
3650 and then No
(Next
(Second_Stmt
)));
3655 (Statements
(Handled_Statement_Sequence
(Orig_Bod
))),
3656 Empty
, Instantiating
=> True);
3659 -- Capture the name of the local variable that holds the
3660 -- result. This must be the first declaration in the block,
3661 -- because its bounds cannot depend on local variables.
3662 -- Otherwise there is no way to declare the result outside
3663 -- of the block. Needless to say, in general the bounds will
3664 -- depend on the actuals in the call.
3666 if Nkind
(Parent
(N
)) /= N_Assignment_Statement
then
3667 Targ1
:= Defining_Identifier
(First
(Declarations
(Blk
)));
3669 -- If the context is an assignment statement, as is the case
3670 -- for the expansion of an extended return, the left-hand
3671 -- side provides bounds even if the return type is
3675 Targ1
:= Name
(Parent
(N
));
3680 if No
(Declarations
(Bod
)) then
3681 Set_Declarations
(Blk
, New_List
);
3686 -- If this is a derived function, establish the proper return type
3688 if Present
(Orig_Subp
) and then Orig_Subp
/= Subp
then
3689 Ret_Type
:= Etype
(Orig_Subp
);
3691 Ret_Type
:= Etype
(Subp
);
3694 -- Create temporaries for the actuals that are expressions, or that are
3695 -- scalars and require copying to preserve semantics.
3697 F
:= First_Formal
(Subp
);
3698 A
:= First_Actual
(N
);
3699 while Present
(F
) loop
3700 if Present
(Renamed_Object
(F
)) then
3702 -- If expander is active, it is an error to try to inline a
3703 -- recursive program. In GNATprove mode, just indicate that the
3704 -- inlining will not happen, and mark the subprogram as not always
3707 if GNATprove_Mode
then
3709 ("cannot inline call to recursive subprogram?", N
, Subp
);
3710 Set_Is_Inlined_Always
(Subp
, False);
3713 ("cannot inline call to recursive subprogram", N
);
3719 -- Reset Last_Assignment for any parameters of mode out or in out, to
3720 -- prevent spurious warnings about overwriting for assignments to the
3721 -- formal in the inlined code.
3723 if Is_Entity_Name
(A
) and then Ekind
(F
) /= E_In_Parameter
then
3724 Set_Last_Assignment
(Entity
(A
), Empty
);
3727 -- If the argument may be a controlling argument in a call within
3728 -- the inlined body, we must preserve its classwide nature to insure
3729 -- that dynamic dispatching take place subsequently. If the formal
3730 -- has a constraint it must be preserved to retain the semantics of
3733 if Is_Class_Wide_Type
(Etype
(F
))
3734 or else (Is_Access_Type
(Etype
(F
))
3735 and then Is_Class_Wide_Type
(Designated_Type
(Etype
(F
))))
3737 Temp_Typ
:= Etype
(F
);
3739 elsif Base_Type
(Etype
(F
)) = Base_Type
(Etype
(A
))
3740 and then Etype
(F
) /= Base_Type
(Etype
(F
))
3741 and then Is_Constrained
(Etype
(F
))
3743 Temp_Typ
:= Etype
(F
);
3746 Temp_Typ
:= Etype
(A
);
3749 -- If the actual is a simple name or a literal, no need to
3750 -- create a temporary, object can be used directly.
3752 -- If the actual is a literal and the formal has its address taken,
3753 -- we cannot pass the literal itself as an argument, so its value
3754 -- must be captured in a temporary. Skip this optimization in
3755 -- GNATprove mode, to make sure any check on a type conversion
3758 if (Is_Entity_Name
(A
)
3760 (not Is_Scalar_Type
(Etype
(A
))
3761 or else Ekind
(Entity
(A
)) = E_Enumeration_Literal
)
3762 and then not GNATprove_Mode
)
3764 -- When the actual is an identifier and the corresponding formal is
3765 -- used only once in the original body, the formal can be substituted
3766 -- directly with the actual parameter. Skip this optimization in
3767 -- GNATprove mode, to make sure any check on a type conversion
3771 (Nkind
(A
) = N_Identifier
3772 and then Formal_Is_Used_Once
(F
)
3773 and then not GNATprove_Mode
)
3776 (Nkind_In
(A
, N_Real_Literal
,
3778 N_Character_Literal
)
3779 and then not Address_Taken
(F
))
3781 if Etype
(F
) /= Etype
(A
) then
3783 (F
, Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
)));
3785 Set_Renamed_Object
(F
, A
);
3789 Temp
:= Make_Temporary
(Loc
, 'C');
3791 -- If the actual for an in/in-out parameter is a view conversion,
3792 -- make it into an unchecked conversion, given that an untagged
3793 -- type conversion is not a proper object for a renaming.
3795 -- In-out conversions that involve real conversions have already
3796 -- been transformed in Expand_Actuals.
3798 if Nkind
(A
) = N_Type_Conversion
3799 and then Ekind
(F
) /= E_In_Parameter
3802 Make_Unchecked_Type_Conversion
(Loc
,
3803 Subtype_Mark
=> New_Occurrence_Of
(Etype
(F
), Loc
),
3804 Expression
=> Relocate_Node
(Expression
(A
)));
3806 -- In GNATprove mode, keep the most precise type of the actual for
3807 -- the temporary variable, when the formal type is unconstrained.
3808 -- Otherwise, the AST may contain unexpected assignment statements
3809 -- to a temporary variable of unconstrained type renaming a local
3810 -- variable of constrained type, which is not expected by
3813 elsif Etype
(F
) /= Etype
(A
)
3814 and then (not GNATprove_Mode
or else Is_Constrained
(Etype
(F
)))
3816 New_A
:= Unchecked_Convert_To
(Etype
(F
), Relocate_Node
(A
));
3817 Temp_Typ
:= Etype
(F
);
3820 New_A
:= Relocate_Node
(A
);
3823 Set_Sloc
(New_A
, Sloc
(N
));
3825 -- If the actual has a by-reference type, it cannot be copied,
3826 -- so its value is captured in a renaming declaration. Otherwise
3827 -- declare a local constant initialized with the actual.
3829 -- We also use a renaming declaration for expressions of an array
3830 -- type that is not bit-packed, both for efficiency reasons and to
3831 -- respect the semantics of the call: in most cases the original
3832 -- call will pass the parameter by reference, and thus the inlined
3833 -- code will have the same semantics.
3835 -- Finally, we need a renaming declaration in the case of limited
3836 -- types for which initialization cannot be by copy either.
3838 if Ekind
(F
) = E_In_Parameter
3839 and then not Is_By_Reference_Type
(Etype
(A
))
3840 and then not Is_Limited_Type
(Etype
(A
))
3842 (not Is_Array_Type
(Etype
(A
))
3843 or else not Is_Object_Reference
(A
)
3844 or else Is_Bit_Packed_Array
(Etype
(A
)))
3847 Make_Object_Declaration
(Loc
,
3848 Defining_Identifier
=> Temp
,
3849 Constant_Present
=> True,
3850 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3851 Expression
=> New_A
);
3854 -- In GNATprove mode, make an explicit copy of input
3855 -- parameters when formal and actual types differ, to make
3856 -- sure any check on the type conversion will be issued.
3857 -- The legality of the copy is ensured by calling first
3858 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3861 and then Ekind
(F
) /= E_Out_Parameter
3862 and then not Same_Type
(Etype
(F
), Etype
(A
))
3864 pragma Assert
(not Is_By_Reference_Type
(Etype
(A
)));
3865 pragma Assert
(not Is_Limited_Type
(Etype
(A
)));
3868 Make_Object_Declaration
(Loc
,
3869 Defining_Identifier
=> Make_Temporary
(Loc
, 'C'),
3870 Constant_Present
=> True,
3871 Object_Definition
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3872 Expression
=> New_Copy_Tree
(New_A
)));
3876 Make_Object_Renaming_Declaration
(Loc
,
3877 Defining_Identifier
=> Temp
,
3878 Subtype_Mark
=> New_Occurrence_Of
(Temp_Typ
, Loc
),
3882 Append
(Decl
, Decls
);
3883 Set_Renamed_Object
(F
, Temp
);
3890 -- Establish target of function call. If context is not assignment or
3891 -- declaration, create a temporary as a target. The declaration for the
3892 -- temporary may be subsequently optimized away if the body is a single
3893 -- expression, or if the left-hand side of the assignment is simple
3894 -- enough, i.e. an entity or an explicit dereference of one.
3896 if Ekind
(Subp
) = E_Function
then
3897 if Nkind
(Parent
(N
)) = N_Assignment_Statement
3898 and then Is_Entity_Name
(Name
(Parent
(N
)))
3900 Targ
:= Name
(Parent
(N
));
3902 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3903 and then Nkind
(Name
(Parent
(N
))) = N_Explicit_Dereference
3904 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3906 Targ
:= Name
(Parent
(N
));
3908 elsif Nkind
(Parent
(N
)) = N_Assignment_Statement
3909 and then Nkind
(Name
(Parent
(N
))) = N_Selected_Component
3910 and then Is_Entity_Name
(Prefix
(Name
(Parent
(N
))))
3912 Targ
:= New_Copy_Tree
(Name
(Parent
(N
)));
3914 elsif Nkind
(Parent
(N
)) = N_Object_Declaration
3915 and then Is_Limited_Type
(Etype
(Subp
))
3917 Targ
:= Defining_Identifier
(Parent
(N
));
3919 -- New semantics: In an object declaration avoid an extra copy
3920 -- of the result of a call to an inlined function that returns
3921 -- an unconstrained type
3924 and then Nkind
(Parent
(N
)) = N_Object_Declaration
3927 Targ
:= Defining_Identifier
(Parent
(N
));
3930 -- Replace call with temporary and create its declaration
3932 Temp
:= Make_Temporary
(Loc
, 'C');
3933 Set_Is_Internal
(Temp
);
3935 -- For the unconstrained case, the generated temporary has the
3936 -- same constrained declaration as the result variable. It may
3937 -- eventually be possible to remove that temporary and use the
3938 -- result variable directly.
3940 if Is_Unc
and then Nkind
(Parent
(N
)) /= N_Assignment_Statement
3943 Make_Object_Declaration
(Loc
,
3944 Defining_Identifier
=> Temp
,
3945 Object_Definition
=>
3946 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
3948 Replace_Formals
(Decl
);
3952 Make_Object_Declaration
(Loc
,
3953 Defining_Identifier
=> Temp
,
3954 Object_Definition
=> New_Occurrence_Of
(Ret_Type
, Loc
));
3956 Set_Etype
(Temp
, Ret_Type
);
3959 Set_No_Initialization
(Decl
);
3960 Append
(Decl
, Decls
);
3961 Rewrite
(N
, New_Occurrence_Of
(Temp
, Loc
));
3966 Insert_Actions
(N
, Decls
);
3970 -- Special management for inlining a call to a function that returns
3971 -- an unconstrained type and initializes an object declaration: we
3972 -- avoid generating undesired extra calls and goto statements.
3975 -- function Func (...) return String is
3978 -- Result : String (1 .. 4);
3980 -- Proc (Result, ...);
3985 -- Result : String := Func (...);
3987 -- Replace this object declaration by:
3989 -- Result : String (1 .. 4);
3990 -- Proc (Result, ...);
3992 Remove_Homonym
(Targ
);
3995 Make_Object_Declaration
3997 Defining_Identifier
=> Targ
,
3998 Object_Definition
=>
3999 New_Copy_Tree
(Object_Definition
(Parent
(Targ1
))));
4000 Replace_Formals
(Decl
);
4001 Rewrite
(Parent
(N
), Decl
);
4002 Analyze
(Parent
(N
));
4004 -- Avoid spurious warnings since we know that this declaration is
4005 -- referenced by the procedure call.
4007 Set_Never_Set_In_Source
(Targ
, False);
4009 -- Remove the local declaration of the extended return stmt from the
4012 Remove
(Parent
(Targ1
));
4014 -- Update the reference to the result (since we have rewriten the
4015 -- object declaration)
4018 Blk_Call_Stmt
: Node_Id
;
4021 -- Capture the call to the procedure
4024 First
(Statements
(Handled_Statement_Sequence
(Blk
)));
4026 (Nkind
(Blk_Call_Stmt
) = N_Procedure_Call_Statement
);
4028 Remove
(First
(Parameter_Associations
(Blk_Call_Stmt
)));
4029 Prepend_To
(Parameter_Associations
(Blk_Call_Stmt
),
4030 New_Occurrence_Of
(Targ
, Loc
));
4033 -- Remove the return statement
4036 (Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4037 N_Simple_Return_Statement
);
4039 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4042 -- Traverse the tree and replace formals with actuals or their thunks.
4043 -- Attach block to tree before analysis and rewriting.
4045 Replace_Formals
(Blk
);
4046 Replace_Formals_In_Aspects
(Blk
);
4047 Set_Parent
(Blk
, N
);
4049 if GNATprove_Mode
then
4052 elsif not Comes_From_Source
(Subp
) or else Is_Predef
then
4058 -- No action needed since return statement has been already removed
4062 elsif Present
(Exit_Lab
) then
4064 -- If there's a single return statement at the end of the subprogram,
4065 -- the corresponding goto statement and the corresponding label are
4070 Nkind
(Last
(Statements
(Handled_Statement_Sequence
(Blk
)))) =
4073 Remove
(Last
(Statements
(Handled_Statement_Sequence
(Blk
))));
4075 Append
(Lab_Decl
, (Declarations
(Blk
)));
4076 Append
(Exit_Lab
, Statements
(Handled_Statement_Sequence
(Blk
)));
4080 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
4081 -- on conflicting private views that Gigi would ignore. If this is a
4082 -- predefined unit, analyze with checks off, as is done in the non-
4083 -- inlined run-time units.
4086 I_Flag
: constant Boolean := In_Inlined_Body
;
4089 In_Inlined_Body
:= True;
4093 Style
: constant Boolean := Style_Check
;
4096 Style_Check
:= False;
4098 -- Search for dispatching calls that use the Object.Operation
4099 -- notation using an Object that is a parameter of the inlined
4100 -- function. We reset the decoration of Operation to force
4101 -- the reanalysis of the inlined dispatching call because
4102 -- the actual object has been inlined.
4104 Reset_Dispatching_Calls
(Blk
);
4106 Analyze
(Blk
, Suppress
=> All_Checks
);
4107 Style_Check
:= Style
;
4114 In_Inlined_Body
:= I_Flag
;
4117 if Ekind
(Subp
) = E_Procedure
then
4118 Rewrite_Procedure_Call
(N
, Blk
);
4121 Rewrite_Function_Call
(N
, Blk
);
4126 -- For the unconstrained case, the replacement of the call has been
4127 -- made prior to the complete analysis of the generated declarations.
4128 -- Propagate the proper type now.
4131 if Nkind
(N
) = N_Identifier
then
4132 Set_Etype
(N
, Etype
(Entity
(N
)));
4134 Set_Etype
(N
, Etype
(Targ1
));
4141 -- Cleanup mapping between formals and actuals for other expansions
4143 F
:= First_Formal
(Subp
);
4144 while Present
(F
) loop
4145 Set_Renamed_Object
(F
, Empty
);
4148 end Expand_Inlined_Call
;
4150 --------------------------
4151 -- Get_Code_Unit_Entity --
4152 --------------------------
4154 function Get_Code_Unit_Entity
(E
: Entity_Id
) return Entity_Id
is
4155 Unit
: Entity_Id
:= Cunit_Entity
(Get_Code_Unit
(E
));
4158 if Ekind
(Unit
) = E_Package_Body
then
4159 Unit
:= Spec_Entity
(Unit
);
4163 end Get_Code_Unit_Entity
;
4165 ------------------------------
4166 -- Has_Excluded_Declaration --
4167 ------------------------------
4169 function Has_Excluded_Declaration
4171 Decls
: List_Id
) return Boolean
4175 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean;
4176 -- Nested subprograms make a given body ineligible for inlining, but
4177 -- we make an exception for instantiations of unchecked conversion.
4178 -- The body has not been analyzed yet, so check the name, and verify
4179 -- that the visible entity with that name is the predefined unit.
4181 -----------------------------
4182 -- Is_Unchecked_Conversion --
4183 -----------------------------
4185 function Is_Unchecked_Conversion
(D
: Node_Id
) return Boolean is
4186 Id
: constant Node_Id
:= Name
(D
);
4190 if Nkind
(Id
) = N_Identifier
4191 and then Chars
(Id
) = Name_Unchecked_Conversion
4193 Conv
:= Current_Entity
(Id
);
4195 elsif Nkind_In
(Id
, N_Selected_Component
, N_Expanded_Name
)
4196 and then Chars
(Selector_Name
(Id
)) = Name_Unchecked_Conversion
4198 Conv
:= Current_Entity
(Selector_Name
(Id
));
4203 return Present
(Conv
)
4204 and then Is_Predefined_Unit
(Get_Source_Unit
(Conv
))
4205 and then Is_Intrinsic_Subprogram
(Conv
);
4206 end Is_Unchecked_Conversion
;
4208 -- Start of processing for Has_Excluded_Declaration
4211 -- No action needed if the check is not needed
4213 if not Check_Inlining_Restrictions
then
4218 while Present
(D
) loop
4220 -- First declarations universally excluded
4222 if Nkind
(D
) = N_Package_Declaration
then
4224 ("cannot inline & (nested package declaration)?", D
, Subp
);
4227 elsif Nkind
(D
) = N_Package_Instantiation
then
4229 ("cannot inline & (nested package instantiation)?", D
, Subp
);
4233 -- Then declarations excluded only for front-end inlining
4235 if Back_End_Inlining
then
4238 elsif Nkind
(D
) = N_Task_Type_Declaration
4239 or else Nkind
(D
) = N_Single_Task_Declaration
4242 ("cannot inline & (nested task type declaration)?", D
, Subp
);
4245 elsif Nkind
(D
) = N_Protected_Type_Declaration
4246 or else Nkind
(D
) = N_Single_Protected_Declaration
4249 ("cannot inline & (nested protected type declaration)?",
4253 elsif Nkind
(D
) = N_Subprogram_Body
then
4255 ("cannot inline & (nested subprogram)?", D
, Subp
);
4258 elsif Nkind
(D
) = N_Function_Instantiation
4259 and then not Is_Unchecked_Conversion
(D
)
4262 ("cannot inline & (nested function instantiation)?", D
, Subp
);
4265 elsif Nkind
(D
) = N_Procedure_Instantiation
then
4267 ("cannot inline & (nested procedure instantiation)?", D
, Subp
);
4270 -- Subtype declarations with predicates will generate predicate
4271 -- functions, i.e. nested subprogram bodies, so inlining is not
4274 elsif Nkind
(D
) = N_Subtype_Declaration
4275 and then Present
(Aspect_Specifications
(D
))
4282 A
:= First
(Aspect_Specifications
(D
));
4283 while Present
(A
) loop
4284 A_Id
:= Get_Aspect_Id
(Chars
(Identifier
(A
)));
4286 if A_Id
= Aspect_Predicate
4287 or else A_Id
= Aspect_Static_Predicate
4288 or else A_Id
= Aspect_Dynamic_Predicate
4291 ("cannot inline & (subtype declaration with "
4292 & "predicate)?", D
, Subp
);
4305 end Has_Excluded_Declaration
;
4307 ----------------------------
4308 -- Has_Excluded_Statement --
4309 ----------------------------
4311 function Has_Excluded_Statement
4313 Stats
: List_Id
) return Boolean
4319 -- No action needed if the check is not needed
4321 if not Check_Inlining_Restrictions
then
4326 while Present
(S
) loop
4327 if Nkind_In
(S
, N_Abort_Statement
,
4328 N_Asynchronous_Select
,
4329 N_Conditional_Entry_Call
,
4330 N_Delay_Relative_Statement
,
4331 N_Delay_Until_Statement
,
4336 ("cannot inline & (non-allowed statement)?", S
, Subp
);
4339 elsif Nkind
(S
) = N_Block_Statement
then
4340 if Present
(Declarations
(S
))
4341 and then Has_Excluded_Declaration
(Subp
, Declarations
(S
))
4345 elsif Present
(Handled_Statement_Sequence
(S
)) then
4346 if not Back_End_Inlining
4349 (Exception_Handlers
(Handled_Statement_Sequence
(S
)))
4352 ("cannot inline& (exception handler)?",
4353 First
(Exception_Handlers
4354 (Handled_Statement_Sequence
(S
))),
4358 elsif Has_Excluded_Statement
4359 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4365 elsif Nkind
(S
) = N_Case_Statement
then
4366 E
:= First
(Alternatives
(S
));
4367 while Present
(E
) loop
4368 if Has_Excluded_Statement
(Subp
, Statements
(E
)) then
4375 elsif Nkind
(S
) = N_If_Statement
then
4376 if Has_Excluded_Statement
(Subp
, Then_Statements
(S
)) then
4380 if Present
(Elsif_Parts
(S
)) then
4381 E
:= First
(Elsif_Parts
(S
));
4382 while Present
(E
) loop
4383 if Has_Excluded_Statement
(Subp
, Then_Statements
(E
)) then
4391 if Present
(Else_Statements
(S
))
4392 and then Has_Excluded_Statement
(Subp
, Else_Statements
(S
))
4397 elsif Nkind
(S
) = N_Loop_Statement
4398 and then Has_Excluded_Statement
(Subp
, Statements
(S
))
4402 elsif Nkind
(S
) = N_Extended_Return_Statement
then
4403 if Present
(Handled_Statement_Sequence
(S
))
4405 Has_Excluded_Statement
4406 (Subp
, Statements
(Handled_Statement_Sequence
(S
)))
4410 elsif not Back_End_Inlining
4411 and then Present
(Handled_Statement_Sequence
(S
))
4413 Present
(Exception_Handlers
4414 (Handled_Statement_Sequence
(S
)))
4417 ("cannot inline& (exception handler)?",
4418 First
(Exception_Handlers
(Handled_Statement_Sequence
(S
))),
4428 end Has_Excluded_Statement
;
4430 --------------------------
4431 -- Has_Initialized_Type --
4432 --------------------------
4434 function Has_Initialized_Type
(E
: Entity_Id
) return Boolean is
4435 E_Body
: constant Node_Id
:= Subprogram_Body
(E
);
4439 if No
(E_Body
) then -- imported subprogram
4443 Decl
:= First
(Declarations
(E_Body
));
4444 while Present
(Decl
) loop
4445 if Nkind
(Decl
) = N_Full_Type_Declaration
4446 and then Present
(Init_Proc
(Defining_Identifier
(Decl
)))
4456 end Has_Initialized_Type
;
4458 -----------------------
4459 -- Has_Single_Return --
4460 -----------------------
4462 function Has_Single_Return
(N
: Node_Id
) return Boolean is
4463 Return_Statement
: Node_Id
:= Empty
;
4465 function Check_Return
(N
: Node_Id
) return Traverse_Result
;
4471 function Check_Return
(N
: Node_Id
) return Traverse_Result
is
4473 if Nkind
(N
) = N_Simple_Return_Statement
then
4474 if Present
(Expression
(N
))
4475 and then Is_Entity_Name
(Expression
(N
))
4477 pragma Assert
(Present
(Entity
(Expression
(N
))));
4479 if No
(Return_Statement
) then
4480 Return_Statement
:= N
;
4485 (Present
(Entity
(Expression
(Return_Statement
))));
4487 if Entity
(Expression
(N
)) =
4488 Entity
(Expression
(Return_Statement
))
4496 -- A return statement within an extended return is a noop after
4499 elsif No
(Expression
(N
))
4500 and then Nkind
(Parent
(Parent
(N
))) =
4501 N_Extended_Return_Statement
4506 -- Expression has wrong form
4511 -- We can only inline a build-in-place function if it has a single
4514 elsif Nkind
(N
) = N_Extended_Return_Statement
then
4515 if No
(Return_Statement
) then
4516 Return_Statement
:= N
;
4528 function Check_All_Returns
is new Traverse_Func
(Check_Return
);
4530 -- Start of processing for Has_Single_Return
4533 if Check_All_Returns
(N
) /= OK
then
4536 elsif Nkind
(Return_Statement
) = N_Extended_Return_Statement
then
4541 Present
(Declarations
(N
))
4542 and then Present
(First
(Declarations
(N
)))
4543 and then Entity
(Expression
(Return_Statement
)) =
4544 Defining_Identifier
(First
(Declarations
(N
)));
4546 end Has_Single_Return
;
4548 -----------------------------
4549 -- In_Main_Unit_Or_Subunit --
4550 -----------------------------
4552 function In_Main_Unit_Or_Subunit
(E
: Entity_Id
) return Boolean is
4553 Comp
: Node_Id
:= Cunit
(Get_Code_Unit
(E
));
4556 -- Check whether the subprogram or package to inline is within the main
4557 -- unit or its spec or within a subunit. In either case there are no
4558 -- additional bodies to process. If the subprogram appears in a parent
4559 -- of the current unit, the check on whether inlining is possible is
4560 -- done in Analyze_Inlined_Bodies.
4562 while Nkind
(Unit
(Comp
)) = N_Subunit
loop
4563 Comp
:= Library_Unit
(Comp
);
4566 return Comp
= Cunit
(Main_Unit
)
4567 or else Comp
= Library_Unit
(Cunit
(Main_Unit
));
4568 end In_Main_Unit_Or_Subunit
;
4574 procedure Initialize
is
4576 Pending_Instantiations
.Init
;
4577 Called_Pending_Instantiations
.Init
;
4578 Inlined_Bodies
.Init
;
4582 for J
in Hash_Headers
'Range loop
4583 Hash_Headers
(J
) := No_Subp
;
4586 Inlined_Calls
:= No_Elist
;
4587 Backend_Calls
:= No_Elist
;
4588 Backend_Instances
:= No_Elist
;
4589 Backend_Inlined_Subps
:= No_Elist
;
4590 Backend_Not_Inlined_Subps
:= No_Elist
;
4593 ------------------------
4594 -- Instantiate_Bodies --
4595 ------------------------
4597 -- Generic bodies contain all the non-local references, so an
4598 -- instantiation does not need any more context than Standard
4599 -- itself, even if the instantiation appears in an inner scope.
4600 -- Generic associations have verified that the contract model is
4601 -- satisfied, so that any error that may occur in the analysis of
4602 -- the body is an internal error.
4604 procedure Instantiate_Bodies
is
4606 procedure Instantiate_Body
(Info
: Pending_Body_Info
);
4607 -- Instantiate a pending body
4609 ------------------------
4610 -- Instantiate_Body --
4611 ------------------------
4613 procedure Instantiate_Body
(Info
: Pending_Body_Info
) is
4615 -- If the instantiation node is absent, it has been removed as part
4616 -- of unreachable code.
4618 if No
(Info
.Inst_Node
) then
4621 -- If the instantiation node is a package body, this means that the
4622 -- instance is a compilation unit and the instantiation has already
4623 -- been performed by Build_Instance_Compilation_Unit_Nodes.
4625 elsif Nkind
(Info
.Inst_Node
) = N_Package_Body
then
4628 elsif Nkind
(Info
.Act_Decl
) = N_Package_Declaration
then
4629 Instantiate_Package_Body
(Info
);
4630 Add_Scope_To_Clean
(Defining_Entity
(Info
.Act_Decl
));
4633 Instantiate_Subprogram_Body
(Info
);
4635 end Instantiate_Body
;
4638 Info
: Pending_Body_Info
;
4640 -- Start of processing for Instantiate_Bodies
4643 if Serious_Errors_Detected
= 0 then
4644 Expander_Active
:= (Operating_Mode
= Opt
.Generate_Code
);
4645 Push_Scope
(Standard_Standard
);
4646 To_Clean
:= New_Elmt_List
;
4648 if Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
4652 -- A body instantiation may generate additional instantiations, so
4653 -- the following loop must scan to the end of a possibly expanding
4654 -- set (that's why we cannot simply use a FOR loop here). We must
4655 -- also capture the element lest the set be entirely reallocated.
4658 if Back_End_Inlining
then
4659 while J
<= Called_Pending_Instantiations
.Last
4660 and then Serious_Errors_Detected
= 0
4662 K
:= Called_Pending_Instantiations
.Table
(J
);
4663 Info
:= Pending_Instantiations
.Table
(K
);
4664 Instantiate_Body
(Info
);
4670 while J
<= Pending_Instantiations
.Last
4671 and then Serious_Errors_Detected
= 0
4673 Info
:= Pending_Instantiations
.Table
(J
);
4674 Instantiate_Body
(Info
);
4680 -- Reset the table of instantiations. Additional instantiations
4681 -- may be added through inlining, when additional bodies are
4684 if Back_End_Inlining
then
4685 Called_Pending_Instantiations
.Init
;
4687 Pending_Instantiations
.Init
;
4690 -- We can now complete the cleanup actions of scopes that contain
4691 -- pending instantiations (skipped for generic units, since we
4692 -- never need any cleanups in generic units).
4695 and then not Is_Generic_Unit
(Main_Unit_Entity
)
4698 elsif Is_Generic_Unit
(Cunit_Entity
(Main_Unit
)) then
4704 end Instantiate_Bodies
;
4710 function Is_Nested
(E
: Entity_Id
) return Boolean is
4715 while Scop
/= Standard_Standard
loop
4716 if Is_Subprogram
(Scop
) then
4719 elsif Ekind
(Scop
) = E_Task_Type
4720 or else Ekind
(Scop
) = E_Entry
4721 or else Ekind
(Scop
) = E_Entry_Family
4726 Scop
:= Scope
(Scop
);
4732 ------------------------
4733 -- List_Inlining_Info --
4734 ------------------------
4736 procedure List_Inlining_Info
is
4742 if not Debug_Flag_Dot_J
then
4746 -- Generate listing of calls inlined by the frontend
4748 if Present
(Inlined_Calls
) then
4750 Elmt
:= First_Elmt
(Inlined_Calls
);
4751 while Present
(Elmt
) loop
4754 if not In_Internal_Unit
(Nod
) then
4758 Write_Str
("List of calls inlined by the frontend");
4765 Write_Location
(Sloc
(Nod
));
4774 -- Generate listing of calls passed to the backend
4776 if Present
(Backend_Calls
) then
4779 Elmt
:= First_Elmt
(Backend_Calls
);
4780 while Present
(Elmt
) loop
4783 if not In_Internal_Unit
(Nod
) then
4787 Write_Str
("List of inlined calls passed to the backend");
4794 Write_Location
(Sloc
(Nod
));
4802 -- Generate listing of instances inlined for the backend
4804 if Present
(Backend_Instances
) then
4807 Elmt
:= First_Elmt
(Backend_Instances
);
4808 while Present
(Elmt
) loop
4811 if not In_Internal_Unit
(Nod
) then
4815 Write_Str
("List of instances inlined for the backend");
4822 Write_Location
(Sloc
(Nod
));
4830 -- Generate listing of subprograms passed to the backend
4832 if Present
(Backend_Inlined_Subps
) and then Back_End_Inlining
then
4835 Elmt
:= First_Elmt
(Backend_Inlined_Subps
);
4836 while Present
(Elmt
) loop
4839 if not In_Internal_Unit
(Nod
) then
4844 ("List of inlined subprograms passed to the backend");
4851 Write_Name
(Chars
(Nod
));
4853 Write_Location
(Sloc
(Nod
));
4862 -- Generate listing of subprograms that cannot be inlined by the backend
4864 if Present
(Backend_Not_Inlined_Subps
) and then Back_End_Inlining
then
4867 Elmt
:= First_Elmt
(Backend_Not_Inlined_Subps
);
4868 while Present
(Elmt
) loop
4871 if not In_Internal_Unit
(Nod
) then
4876 ("List of subprograms that cannot be inlined by backend");
4883 Write_Name
(Chars
(Nod
));
4885 Write_Location
(Sloc
(Nod
));
4893 end List_Inlining_Info
;
4901 Pending_Instantiations
.Release
;
4902 Pending_Instantiations
.Locked
:= True;
4903 Called_Pending_Instantiations
.Release
;
4904 Called_Pending_Instantiations
.Locked
:= True;
4905 Inlined_Bodies
.Release
;
4906 Inlined_Bodies
.Locked
:= True;
4908 Successors
.Locked
:= True;
4910 Inlined
.Locked
:= True;
4913 --------------------------------
4914 -- Remove_Aspects_And_Pragmas --
4915 --------------------------------
4917 procedure Remove_Aspects_And_Pragmas
(Body_Decl
: Node_Id
) is
4918 procedure Remove_Items
(List
: List_Id
);
4919 -- Remove all useless aspects/pragmas from a particular list
4925 procedure Remove_Items
(List
: List_Id
) is
4928 Next_Item
: Node_Id
;
4931 -- Traverse the list looking for an aspect specification or a pragma
4933 Item
:= First
(List
);
4934 while Present
(Item
) loop
4935 Next_Item
:= Next
(Item
);
4937 if Nkind
(Item
) = N_Aspect_Specification
then
4938 Item_Id
:= Identifier
(Item
);
4939 elsif Nkind
(Item
) = N_Pragma
then
4940 Item_Id
:= Pragma_Identifier
(Item
);
4945 if Present
(Item_Id
)
4946 and then Nam_In
(Chars
(Item_Id
), Name_Contract_Cases
,
4951 Name_Refined_Global
,
4952 Name_Refined_Depends
,
4966 -- Start of processing for Remove_Aspects_And_Pragmas
4969 Remove_Items
(Aspect_Specifications
(Body_Decl
));
4970 Remove_Items
(Declarations
(Body_Decl
));
4972 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
4973 -- in the body of the subprogram.
4975 Remove_Items
(Statements
(Handled_Statement_Sequence
(Body_Decl
)));
4976 end Remove_Aspects_And_Pragmas
;
4978 --------------------------
4979 -- Remove_Dead_Instance --
4980 --------------------------
4982 procedure Remove_Dead_Instance
(N
: Node_Id
) is
4987 while J
<= Pending_Instantiations
.Last
loop
4988 if Pending_Instantiations
.Table
(J
).Inst_Node
= N
then
4989 Pending_Instantiations
.Table
(J
).Inst_Node
:= Empty
;
4995 end Remove_Dead_Instance
;