hppa: Revise REG+D address support to allow long displacements before reload
[official-gcc.git] / gcc / ada / inline.adb
blob5fff88144b2789c22b7ffa8a85daf554db3b47bd
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- I N L I N E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2023, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
26 with Alloc;
27 with Aspects; use Aspects;
28 with Atree; use Atree;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Einfo.Entities; use Einfo.Entities;
32 with Einfo.Utils; use Einfo.Utils;
33 with Elists; use Elists;
34 with Errout; use Errout;
35 with Exp_Ch6; use Exp_Ch6;
36 with Exp_Ch7; use Exp_Ch7;
37 with Exp_Tss; use Exp_Tss;
38 with Exp_Util; use Exp_Util;
39 with Fname; use Fname;
40 with Fname.UF; use Fname.UF;
41 with Lib; use Lib;
42 with Namet; use Namet;
43 with Nmake; use Nmake;
44 with Nlists; use Nlists;
45 with Output; use Output;
46 with Sem_Aux; use Sem_Aux;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Ch10; use Sem_Ch10;
49 with Sem_Ch12; use Sem_Ch12;
50 with Sem_Prag; use Sem_Prag;
51 with Sem_Res; use Sem_Res;
52 with Sem_Util; use Sem_Util;
53 with Sinfo; use Sinfo;
54 with Sinfo.Nodes; use Sinfo.Nodes;
55 with Sinfo.Utils; use Sinfo.Utils;
56 with Sinput; use Sinput;
57 with Snames; use Snames;
58 with Stand; use Stand;
59 with Table;
60 with Tbuild; use Tbuild;
61 with Uintp; use Uintp;
62 with Uname; use Uname;
64 with GNAT.HTable;
66 package body Inline is
68 Check_Inlining_Restrictions : constant Boolean := True;
69 -- In the following cases the frontend rejects inlining because they
70 -- are not handled well by the backend. This variable facilitates
71 -- disabling these restrictions to evaluate future versions of the
72 -- GCC backend in which some of the restrictions may be supported.
74 -- - subprograms that have:
75 -- - nested subprograms
76 -- - instantiations
77 -- - package declarations
78 -- - task or protected object declarations
79 -- - some of the following statements:
80 -- - abort
81 -- - asynchronous-select
82 -- - conditional-entry-call
83 -- - delay-relative
84 -- - delay-until
85 -- - selective-accept
86 -- - timed-entry-call
88 Inlined_Calls : Elist_Id;
89 -- List of frontend inlined calls
91 Backend_Calls : Elist_Id;
92 -- List of inline calls passed to the backend
94 Backend_Instances : Elist_Id;
95 -- List of instances inlined for the backend
97 Backend_Inlined_Subps : Elist_Id;
98 -- List of subprograms inlined by the backend
100 Backend_Not_Inlined_Subps : Elist_Id;
101 -- List of subprograms that cannot be inlined by the backend
103 -----------------------------
104 -- Pending_Instantiations --
105 -----------------------------
107 -- We make entries in this table for the pending instantiations of generic
108 -- bodies that are created during semantic analysis. After the analysis is
109 -- complete, calling Instantiate_Bodies performs the actual instantiations.
111 package Pending_Instantiations is new Table.Table (
112 Table_Component_Type => Pending_Body_Info,
113 Table_Index_Type => Int,
114 Table_Low_Bound => 0,
115 Table_Initial => Alloc.Pending_Instantiations_Initial,
116 Table_Increment => Alloc.Pending_Instantiations_Increment,
117 Table_Name => "Pending_Instantiations");
119 -------------------------------------
120 -- Called_Pending_Instantiations --
121 -------------------------------------
123 -- With back-end inlining, the pending instantiations that are not in the
124 -- main unit or subunit are performed only after a call to the subprogram
125 -- instance, or to a subprogram within the package instance, is inlined.
126 -- Since such a call can be within a subsequent pending instantiation,
127 -- we make entries in this table that stores the index of these "called"
128 -- pending instantiations and perform them when the table is populated.
130 package Called_Pending_Instantiations is new Table.Table (
131 Table_Component_Type => Int,
132 Table_Index_Type => Int,
133 Table_Low_Bound => 0,
134 Table_Initial => Alloc.Pending_Instantiations_Initial,
135 Table_Increment => Alloc.Pending_Instantiations_Increment,
136 Table_Name => "Called_Pending_Instantiations");
138 ---------------------------------
139 -- To_Pending_Instantiations --
140 ---------------------------------
142 -- With back-end inlining, we also need to have a map from the pending
143 -- instantiations to their index in the Pending_Instantiations table.
145 Node_Table_Size : constant := 257;
146 -- Number of headers in hash table
148 subtype Node_Header_Num is Integer range 0 .. Node_Table_Size - 1;
149 -- Range of headers in hash table
151 function Node_Hash (Id : Node_Id) return Node_Header_Num;
152 -- Simple hash function for Node_Ids
154 package To_Pending_Instantiations is new GNAT.Htable.Simple_HTable
155 (Header_Num => Node_Header_Num,
156 Element => Int,
157 No_Element => -1,
158 Key => Node_Id,
159 Hash => Node_Hash,
160 Equal => "=");
162 -----------------
163 -- Node_Hash --
164 -----------------
166 function Node_Hash (Id : Node_Id) return Node_Header_Num is
167 begin
168 return Node_Header_Num (Id mod Node_Table_Size);
169 end Node_Hash;
171 --------------------
172 -- Inlined Bodies --
173 --------------------
175 -- Inlined functions are actually placed in line by the backend if the
176 -- corresponding bodies are available (i.e. compiled). Whenever we find
177 -- a call to an inlined subprogram, we add the name of the enclosing
178 -- compilation unit to a worklist. After all compilation, and after
179 -- expansion of generic bodies, we traverse the list of pending bodies
180 -- and compile them as well.
182 package Inlined_Bodies is new Table.Table (
183 Table_Component_Type => Entity_Id,
184 Table_Index_Type => Int,
185 Table_Low_Bound => 0,
186 Table_Initial => Alloc.Inlined_Bodies_Initial,
187 Table_Increment => Alloc.Inlined_Bodies_Increment,
188 Table_Name => "Inlined_Bodies");
190 -----------------------
191 -- Inline Processing --
192 -----------------------
194 -- For each call to an inlined subprogram, we make entries in a table
195 -- that stores caller and callee, and indicates the call direction from
196 -- one to the other. We also record the compilation unit that contains
197 -- the callee. After analyzing the bodies of all such compilation units,
198 -- we compute the transitive closure of inlined subprograms called from
199 -- the main compilation unit and make it available to the code generator
200 -- in no particular order, thus allowing cycles in the call graph.
202 Last_Inlined : Entity_Id := Empty;
204 -- For each entry in the table we keep a list of successors in topological
205 -- order, i.e. callers of the current subprogram.
207 type Subp_Index is new Nat;
208 No_Subp : constant Subp_Index := 0;
210 -- The subprogram entities are hashed into the Inlined table
212 Num_Hash_Headers : constant := 512;
214 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
215 of Subp_Index;
217 type Succ_Index is new Nat;
218 No_Succ : constant Succ_Index := 0;
220 type Succ_Info is record
221 Subp : Subp_Index;
222 Next : Succ_Index;
223 end record;
225 -- The following table stores list elements for the successor lists. These
226 -- lists cannot be chained directly through entries in the Inlined table,
227 -- because a given subprogram can appear in several such lists.
229 package Successors is new Table.Table (
230 Table_Component_Type => Succ_Info,
231 Table_Index_Type => Succ_Index,
232 Table_Low_Bound => 1,
233 Table_Initial => Alloc.Successors_Initial,
234 Table_Increment => Alloc.Successors_Increment,
235 Table_Name => "Successors");
237 type Subp_Info is record
238 Name : Entity_Id := Empty;
239 Next : Subp_Index := No_Subp;
240 First_Succ : Succ_Index := No_Succ;
241 Main_Call : Boolean := False;
242 Processed : Boolean := False;
243 end record;
245 package Inlined is new Table.Table (
246 Table_Component_Type => Subp_Info,
247 Table_Index_Type => Subp_Index,
248 Table_Low_Bound => 1,
249 Table_Initial => Alloc.Inlined_Initial,
250 Table_Increment => Alloc.Inlined_Increment,
251 Table_Name => "Inlined");
253 -----------------------
254 -- Local Subprograms --
255 -----------------------
257 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
258 -- Make two entries in Inlined table, for an inlined subprogram being
259 -- called, and for the inlined subprogram that contains the call. If
260 -- the call is in the main compilation unit, Caller is Empty.
262 procedure Add_Inlined_Instance (E : Entity_Id);
263 -- Add instance E to the list of inlined instances for the unit
265 procedure Add_Inlined_Subprogram (E : Entity_Id);
266 -- Add subprogram E to the list of inlined subprograms for the unit
268 function Add_Subp (E : Entity_Id) return Subp_Index;
269 -- Make entry in Inlined table for subprogram E, or return table index
270 -- that already holds E.
272 procedure Establish_Actual_Mapping_For_Inlined_Call
273 (N : Node_Id;
274 Subp : Entity_Id;
275 Decls : List_Id;
276 Body_Or_Expr_To_Check : Node_Id);
277 -- Establish a mapping from formals to actuals in the call N for the target
278 -- subprogram Subp, and create temporaries or renamings when needed for the
279 -- actuals that are expressions (except for actuals given by simple entity
280 -- names or literals) or that are scalars that require copying to preserve
281 -- semantics. Any temporary objects that are created are inserted in Decls.
282 -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
283 -- of an expression function), which may be traversed to count formal uses.
285 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
286 pragma Inline (Get_Code_Unit_Entity);
287 -- Return the entity node for the unit containing E. Always return the spec
288 -- for a package.
290 function Has_Initialized_Type (E : Entity_Id) return Boolean;
291 -- If a candidate for inlining contains type declarations for types with
292 -- nontrivial initialization procedures, they are not worth inlining.
294 function Has_Single_Return (N : Node_Id) return Boolean;
295 -- In general we cannot inline functions that return unconstrained type.
296 -- However, we can handle such functions if all return statements return
297 -- a local variable that is the first declaration in the body of the
298 -- function. In that case the call can be replaced by that local
299 -- variable as is done for other inlined calls.
301 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
302 -- Return True if E is in the main unit or its spec or in a subunit
304 function Is_Nested (E : Entity_Id) return Boolean;
305 -- If the function is nested inside some other function, it will always
306 -- be compiled if that function is, so don't add it to the inline list.
307 -- We cannot compile a nested function outside the scope of the containing
308 -- function anyway. This is also the case if the function is defined in a
309 -- task body or within an entry (for example, an initialization procedure).
311 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id);
312 -- Remove all aspects and/or pragmas that have no meaning in inlined body
313 -- Body_Decl. The analysis of these items is performed on the non-inlined
314 -- body. The items currently removed are:
315 -- Always_Terminates
316 -- Contract_Cases
317 -- Global
318 -- Depends
319 -- Exceptional_Cases
320 -- Postcondition
321 -- Precondition
322 -- Refined_Global
323 -- Refined_Depends
324 -- Refined_Post
325 -- Subprogram_Variant
326 -- Test_Case
327 -- Unmodified
328 -- Unreferenced
330 procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id);
331 -- Reset the Renamed_Object field to Empty on all formals of Subp, which
332 -- can be set by a call to Establish_Actual_Mapping_For_Inlined_Call.
334 ------------------------------
335 -- Deferred Cleanup Actions --
336 ------------------------------
338 -- The cleanup actions for scopes that contain package instantiations with
339 -- a body are delayed until after the package body is instantiated. because
340 -- the body may contain finalizable objects or other constructs that affect
341 -- the cleanup code. A scope that contains such instantiations only needs
342 -- to be finalized once, even though it may contain more than one instance.
343 -- We keep a list of scopes that must still be finalized and Cleanup_Scopes
344 -- will be invoked after all the body instantiations have been completed.
346 To_Clean : Elist_Id;
348 procedure Add_Scope_To_Clean (Scop : Entity_Id);
349 -- Build set of scopes on which cleanup actions must be performed
351 procedure Cleanup_Scopes;
352 -- Complete cleanup actions on scopes that need it
354 --------------
355 -- Add_Call --
356 --------------
358 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
359 P1 : constant Subp_Index := Add_Subp (Called);
360 P2 : Subp_Index;
361 J : Succ_Index;
363 begin
364 if Present (Caller) then
365 P2 := Add_Subp (Caller);
367 -- Add P1 to the list of successors of P2, if not already there.
368 -- Note that P2 may contain more than one call to P1, and only
369 -- one needs to be recorded.
371 J := Inlined.Table (P2).First_Succ;
372 while J /= No_Succ loop
373 if Successors.Table (J).Subp = P1 then
374 return;
375 end if;
377 J := Successors.Table (J).Next;
378 end loop;
380 -- On exit, make a successor entry for P1
382 Successors.Increment_Last;
383 Successors.Table (Successors.Last).Subp := P1;
384 Successors.Table (Successors.Last).Next :=
385 Inlined.Table (P2).First_Succ;
386 Inlined.Table (P2).First_Succ := Successors.Last;
387 else
388 Inlined.Table (P1).Main_Call := True;
389 end if;
390 end Add_Call;
392 ----------------------
393 -- Add_Inlined_Body --
394 ----------------------
396 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
398 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
399 -- Level of inlining for the call: Dont_Inline means no inlining,
400 -- Inline_Call means that only the call is considered for inlining,
401 -- Inline_Package means that the call is considered for inlining and
402 -- its package compiled and scanned for more inlining opportunities.
404 function Is_Non_Loading_Expression_Function
405 (Id : Entity_Id) return Boolean;
406 -- Determine whether arbitrary entity Id denotes a subprogram which is
407 -- either
409 -- * An expression function
411 -- * A function completed by an expression function where both the
412 -- spec and body are in the same context.
414 function Must_Inline return Inline_Level_Type;
415 -- Inlining is only done if the call statement N is in the main unit,
416 -- or within the body of another inlined subprogram.
418 ----------------------------------------
419 -- Is_Non_Loading_Expression_Function --
420 ----------------------------------------
422 function Is_Non_Loading_Expression_Function
423 (Id : Entity_Id) return Boolean
425 Body_Decl : Node_Id;
426 Body_Id : Entity_Id;
427 Spec_Decl : Node_Id;
429 begin
430 -- A stand-alone expression function is transformed into a spec-body
431 -- pair in-place. Since both the spec and body are in the same list,
432 -- the inlining of such an expression function does not need to load
433 -- anything extra.
435 if Is_Expression_Function (Id) then
436 return True;
438 -- A function may be completed by an expression function
440 elsif Ekind (Id) = E_Function then
441 Spec_Decl := Unit_Declaration_Node (Id);
443 if Nkind (Spec_Decl) = N_Subprogram_Declaration then
444 Body_Id := Corresponding_Body (Spec_Decl);
446 if Present (Body_Id) then
447 Body_Decl := Unit_Declaration_Node (Body_Id);
449 -- The inlining of a completing expression function does
450 -- not need to load anything extra when both the spec and
451 -- body are in the same context.
453 return
454 Was_Expression_Function (Body_Decl)
455 and then Parent (Spec_Decl) = Parent (Body_Decl);
456 end if;
457 end if;
458 end if;
460 return False;
461 end Is_Non_Loading_Expression_Function;
463 -----------------
464 -- Must_Inline --
465 -----------------
467 function Must_Inline return Inline_Level_Type is
468 Scop : Entity_Id;
469 Comp : Node_Id;
471 begin
472 -- Check if call is in main unit
474 Scop := Current_Scope;
476 -- Do not try to inline if scope is standard. This could happen, for
477 -- example, for a call to Add_Global_Declaration, and it causes
478 -- trouble to try to inline at this level.
480 if Scop = Standard_Standard then
481 return Dont_Inline;
482 end if;
484 -- Otherwise lookup scope stack to outer scope
486 while Scope (Scop) /= Standard_Standard
487 and then not Is_Child_Unit (Scop)
488 loop
489 Scop := Scope (Scop);
490 end loop;
492 Comp := Parent (Scop);
493 while Nkind (Comp) /= N_Compilation_Unit loop
494 Comp := Parent (Comp);
495 end loop;
497 -- If the call is in the main unit, inline the call and compile the
498 -- package of the subprogram to find more calls to be inlined.
500 if Comp = Cunit (Main_Unit)
501 or else Comp = Library_Unit (Cunit (Main_Unit))
502 then
503 Add_Call (E);
504 return Inline_Package;
505 end if;
507 -- The call is not in the main unit. See if it is in some subprogram
508 -- that can be inlined outside its unit. If so, inline the call and,
509 -- if the inlining level is set to 1, stop there; otherwise also
510 -- compile the package as above.
512 Scop := Current_Scope;
513 while Scope (Scop) /= Standard_Standard
514 and then not Is_Child_Unit (Scop)
515 loop
516 if Is_Overloadable (Scop)
517 and then Is_Inlined (Scop)
518 and then not Is_Nested (Scop)
519 then
520 Add_Call (E, Scop);
522 if Inline_Level = 1 then
523 return Inline_Call;
524 else
525 return Inline_Package;
526 end if;
527 end if;
529 Scop := Scope (Scop);
530 end loop;
532 return Dont_Inline;
533 end Must_Inline;
535 Inst : Entity_Id;
536 Inst_Decl : Node_Id;
537 Level : Inline_Level_Type;
539 -- Start of processing for Add_Inlined_Body
541 begin
542 Append_New_Elmt (N, To => Backend_Calls);
544 -- Skip subprograms that cannot or need not be inlined outside their
545 -- unit or parent subprogram.
547 if Is_Abstract_Subprogram (E)
548 or else Convention (E) = Convention_Protected
549 or else In_Main_Unit_Or_Subunit (E)
550 or else Is_Nested (E)
551 then
552 return;
553 end if;
555 -- Find out whether the call must be inlined. Unless the result is
556 -- Dont_Inline, Must_Inline also creates an edge for the call in the
557 -- callgraph; however, it will not be activated until after Is_Called
558 -- is set on the subprogram.
560 Level := Must_Inline;
562 if Level = Dont_Inline then
563 return;
564 end if;
566 -- If a previous call to the subprogram has been inlined, nothing to do
568 if Is_Called (E) then
569 return;
570 end if;
572 -- If the subprogram is an instance, then inline the instance
574 if Is_Generic_Instance (E) then
575 Add_Inlined_Instance (E);
576 end if;
578 -- Mark the subprogram as called
580 Set_Is_Called (E);
582 -- If the call was generated by the compiler and is to a subprogram in
583 -- a run-time unit, we need to suppress debugging information for it,
584 -- so that the code that is eventually inlined will not affect the
585 -- debugging of the program. We do not do it if the call comes from
586 -- source because, even if the call is inlined, the user may expect it
587 -- to be present in the debugging information.
589 if not Comes_From_Source (N)
590 and then In_Extended_Main_Source_Unit (N)
591 and then Is_Predefined_Unit (Get_Source_Unit (E))
592 then
593 Set_Needs_Debug_Info (E, False);
594 end if;
596 -- If the subprogram is an expression function, or is completed by one
597 -- where both the spec and body are in the same context, then there is
598 -- no need to load any package body since the body of the function is
599 -- in the spec.
601 if Is_Non_Loading_Expression_Function (E) then
602 return;
603 end if;
605 -- Find unit containing E, and add to list of inlined bodies if needed.
606 -- Library-level functions must be handled specially, because there is
607 -- no enclosing package to retrieve. In this case, it is the body of
608 -- the function that will have to be loaded.
610 declare
611 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
613 begin
614 if Pack = E then
615 Inlined_Bodies.Increment_Last;
616 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
618 else
619 pragma Assert (Ekind (Pack) = E_Package);
621 -- If the subprogram is within an instance, inline the instance
623 if Comes_From_Source (E) then
624 Inst := Scope (E);
626 while Present (Inst) and then Inst /= Standard_Standard loop
627 exit when Is_Generic_Instance (Inst);
628 Inst := Scope (Inst);
629 end loop;
631 if Present (Inst)
632 and then Is_Generic_Instance (Inst)
633 and then not Is_Called (Inst)
634 then
635 Inst_Decl := Unit_Declaration_Node (Inst);
637 -- Do not inline the instance if the body already exists,
638 -- or the instance node is simply missing.
640 if Present (Corresponding_Body (Inst_Decl))
641 or else (Nkind (Parent (Inst_Decl)) /= N_Compilation_Unit
642 and then No (Next (Inst_Decl)))
643 then
644 Set_Is_Called (Inst);
645 else
646 Add_Inlined_Instance (Inst);
647 end if;
648 end if;
649 end if;
651 -- If the unit containing E is an instance, nothing more to do
653 if Is_Generic_Instance (Pack) then
654 null;
656 -- Do not inline the package if the subprogram is an init proc
657 -- or other internally generated subprogram, because in that
658 -- case the subprogram body appears in the same unit that
659 -- declares the type, and that body is visible to the back end.
660 -- Do not inline it either if it is in the main unit.
661 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
662 -- calls if the back end takes care of inlining the call.
663 -- Note that Level is in Inline_Call | Inline_Package here.
665 elsif ((Level = Inline_Call
666 and then Has_Pragma_Inline_Always (E)
667 and then Back_End_Inlining)
668 or else Level = Inline_Package)
669 and then not Is_Inlined (Pack)
670 and then not Is_Internal (E)
671 and then not In_Main_Unit_Or_Subunit (Pack)
672 then
673 Set_Is_Inlined (Pack);
674 Inlined_Bodies.Increment_Last;
675 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
676 end if;
677 end if;
679 -- Ensure that Analyze_Inlined_Bodies will be invoked after
680 -- completing the analysis of the current unit.
682 Inline_Processing_Required := True;
683 end;
684 end Add_Inlined_Body;
686 --------------------------
687 -- Add_Inlined_Instance --
688 --------------------------
690 procedure Add_Inlined_Instance (E : Entity_Id) is
691 Decl_Node : constant Node_Id := Unit_Declaration_Node (E);
692 Index : Int;
694 begin
695 -- This machinery is only used with back-end inlining
697 if not Back_End_Inlining then
698 return;
699 end if;
701 -- Register the instance in the list
703 Append_New_Elmt (Decl_Node, To => Backend_Instances);
705 -- Retrieve the index of its corresponding pending instantiation
706 -- and mark this corresponding pending instantiation as needed.
708 Index := To_Pending_Instantiations.Get (Decl_Node);
709 if Index >= 0 then
710 Called_Pending_Instantiations.Append (Index);
711 else
712 pragma Assert (False);
713 null;
714 end if;
716 Set_Is_Called (E);
717 end Add_Inlined_Instance;
719 ----------------------------
720 -- Add_Inlined_Subprogram --
721 ----------------------------
723 procedure Add_Inlined_Subprogram (E : Entity_Id) is
724 Decl : constant Node_Id := Parent (Declaration_Node (E));
725 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
727 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
728 -- Append Subp to the list of subprograms inlined by the backend
730 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
731 -- Append Subp to the list of subprograms that cannot be inlined by
732 -- the backend.
734 -----------------------------------------
735 -- Register_Backend_Inlined_Subprogram --
736 -----------------------------------------
738 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
739 begin
740 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
741 end Register_Backend_Inlined_Subprogram;
743 ---------------------------------------------
744 -- Register_Backend_Not_Inlined_Subprogram --
745 ---------------------------------------------
747 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
748 begin
749 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
750 end Register_Backend_Not_Inlined_Subprogram;
752 -- Start of processing for Add_Inlined_Subprogram
754 begin
755 -- We can inline the subprogram if its unit is known to be inlined or is
756 -- an instance whose body will be analyzed anyway or the subprogram was
757 -- generated as a body by the compiler (for example an initialization
758 -- procedure) or its declaration was provided along with the body (for
759 -- example an expression function) and it does not declare types with
760 -- nontrivial initialization procedures.
762 if (Is_Inlined (Pack)
763 or else Is_Generic_Instance (Pack)
764 or else Nkind (Decl) = N_Subprogram_Body
765 or else Present (Corresponding_Body (Decl)))
766 and then not Has_Initialized_Type (E)
767 then
768 Register_Backend_Inlined_Subprogram (E);
770 if No (Last_Inlined) then
771 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
772 else
773 Set_Next_Inlined_Subprogram (Last_Inlined, E);
774 end if;
776 Last_Inlined := E;
778 else
779 Register_Backend_Not_Inlined_Subprogram (E);
780 end if;
781 end Add_Inlined_Subprogram;
783 --------------------------------
784 -- Add_Pending_Instantiation --
785 --------------------------------
787 procedure Add_Pending_Instantiation
788 (Inst : Node_Id;
789 Act_Decl : Node_Id;
790 Fin_Scop : Node_Id := Empty)
792 Act_Decl_Id : Entity_Id;
793 Index : Int;
795 begin
796 -- Here is a defense against a ludicrous number of instantiations
797 -- caused by a circular set of instantiation attempts.
799 if Pending_Instantiations.Last + 1 >= Maximum_Instantiations then
800 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
801 Error_Msg_N ("too many instantiations, exceeds max of^", Inst);
802 Error_Msg_N ("\limit can be changed using -gnateinn switch", Inst);
803 raise Unrecoverable_Error;
804 end if;
806 -- Capture the body of the generic instantiation along with its context
807 -- for later processing by Instantiate_Bodies.
809 Pending_Instantiations.Append
810 ((Inst_Node => Inst,
811 Act_Decl => Act_Decl,
812 Fin_Scop => Fin_Scop,
813 Config_Switches => Save_Config_Switches,
814 Current_Sem_Unit => Current_Sem_Unit,
815 Expander_Status => Expander_Active,
816 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
817 Scope_Suppress => Scope_Suppress,
818 Warnings => Save_Warnings));
820 -- With back-end inlining, also associate the index to the instantiation
822 if Back_End_Inlining then
823 Act_Decl_Id := Defining_Entity (Act_Decl);
824 Index := Pending_Instantiations.Last;
826 To_Pending_Instantiations.Set (Act_Decl, Index);
828 -- If an instantiation is in the main unit or subunit, or is a nested
829 -- subprogram, then its body is needed as per the analysis done in
830 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
832 if In_Main_Unit_Or_Subunit (Act_Decl_Id)
833 or else (Is_Subprogram (Act_Decl_Id)
834 and then Is_Nested (Act_Decl_Id))
835 then
836 Called_Pending_Instantiations.Append (Index);
838 Set_Is_Called (Act_Decl_Id);
839 end if;
840 end if;
841 end Add_Pending_Instantiation;
843 ------------------------
844 -- Add_Scope_To_Clean --
845 ------------------------
847 procedure Add_Scope_To_Clean (Scop : Entity_Id) is
848 Elmt : Elmt_Id;
850 begin
851 Elmt := First_Elmt (To_Clean);
852 while Present (Elmt) loop
853 if Node (Elmt) = Scop then
854 return;
855 end if;
857 Next_Elmt (Elmt);
858 end loop;
860 Append_Elmt (Scop, To_Clean);
861 end Add_Scope_To_Clean;
863 --------------
864 -- Add_Subp --
865 --------------
867 function Add_Subp (E : Entity_Id) return Subp_Index is
868 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
869 J : Subp_Index;
871 procedure New_Entry;
872 -- Initialize entry in Inlined table
874 procedure New_Entry is
875 begin
876 Inlined.Increment_Last;
877 Inlined.Table (Inlined.Last).Name := E;
878 Inlined.Table (Inlined.Last).Next := No_Subp;
879 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
880 Inlined.Table (Inlined.Last).Main_Call := False;
881 Inlined.Table (Inlined.Last).Processed := False;
882 end New_Entry;
884 -- Start of processing for Add_Subp
886 begin
887 if Hash_Headers (Index) = No_Subp then
888 New_Entry;
889 Hash_Headers (Index) := Inlined.Last;
890 return Inlined.Last;
892 else
893 J := Hash_Headers (Index);
894 while J /= No_Subp loop
895 if Inlined.Table (J).Name = E then
896 return J;
897 else
898 Index := J;
899 J := Inlined.Table (J).Next;
900 end if;
901 end loop;
903 -- On exit, subprogram was not found. Enter in table. Index is
904 -- the current last entry on the hash chain.
906 New_Entry;
907 Inlined.Table (Index).Next := Inlined.Last;
908 return Inlined.Last;
909 end if;
910 end Add_Subp;
912 ----------------------------
913 -- Analyze_Inlined_Bodies --
914 ----------------------------
916 procedure Analyze_Inlined_Bodies is
917 Comp_Unit : Node_Id;
918 J : Int;
919 Pack : Entity_Id;
920 Subp : Subp_Index;
921 S : Succ_Index;
923 type Pending_Index is new Nat;
925 package Pending_Inlined is new Table.Table (
926 Table_Component_Type => Subp_Index,
927 Table_Index_Type => Pending_Index,
928 Table_Low_Bound => 1,
929 Table_Initial => Alloc.Inlined_Initial,
930 Table_Increment => Alloc.Inlined_Increment,
931 Table_Name => "Pending_Inlined");
932 -- The workpile used to compute the transitive closure
934 -- Start of processing for Analyze_Inlined_Bodies
936 begin
937 if Serious_Errors_Detected = 0 then
938 Push_Scope (Standard_Standard);
940 J := 0;
941 while J <= Inlined_Bodies.Last
942 and then Serious_Errors_Detected = 0
943 loop
944 Pack := Inlined_Bodies.Table (J);
945 while Present (Pack)
946 and then Scope (Pack) /= Standard_Standard
947 and then not Is_Child_Unit (Pack)
948 loop
949 Pack := Scope (Pack);
950 end loop;
952 Comp_Unit := Parent (Pack);
953 while Present (Comp_Unit)
954 and then Nkind (Comp_Unit) /= N_Compilation_Unit
955 loop
956 Comp_Unit := Parent (Comp_Unit);
957 end loop;
959 -- Load the body if it exists and contains inlineable entities,
960 -- unless it is the main unit, or is an instance whose body has
961 -- already been analyzed.
963 if Present (Comp_Unit)
964 and then Comp_Unit /= Cunit (Main_Unit)
965 and then Body_Required (Comp_Unit)
966 and then
967 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
968 or else
969 (No (Corresponding_Body (Unit (Comp_Unit)))
970 and then Body_Needed_For_Inlining
971 (Defining_Entity (Unit (Comp_Unit)))))
972 then
973 declare
974 Bname : constant Unit_Name_Type :=
975 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
977 OK : Boolean;
979 begin
980 if not Is_Loaded (Bname) then
981 Style_Check := False;
982 Load_Needed_Body (Comp_Unit, OK);
984 if not OK then
986 -- Warn that a body was not available for inlining
987 -- by the back-end.
989 Error_Msg_Unit_1 := Bname;
990 Error_Msg_N
991 ("one or more inlined subprograms accessed in $!??",
992 Comp_Unit);
993 Error_Msg_File_1 :=
994 Get_File_Name (Bname, Subunit => False);
995 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
996 end if;
997 end if;
998 end;
999 end if;
1001 J := J + 1;
1003 if J > Inlined_Bodies.Last then
1005 -- The analysis of required bodies may have produced additional
1006 -- generic instantiations. To obtain further inlining, we need
1007 -- to perform another round of generic body instantiations.
1009 Instantiate_Bodies;
1011 -- Symmetrically, the instantiation of required generic bodies
1012 -- may have caused additional bodies to be inlined. To obtain
1013 -- further inlining, we keep looping over the inlined bodies.
1014 end if;
1015 end loop;
1017 -- The list of inlined subprograms is an overestimate, because it
1018 -- includes inlined functions called from functions that are compiled
1019 -- as part of an inlined package, but are not themselves called. An
1020 -- accurate computation of just those subprograms that are needed
1021 -- requires that we perform a transitive closure over the call graph,
1022 -- starting from calls in the main compilation unit.
1024 for Index in Inlined.First .. Inlined.Last loop
1025 if not Is_Called (Inlined.Table (Index).Name) then
1027 -- This means that Add_Inlined_Body added the subprogram to the
1028 -- table but wasn't able to handle its code unit. Do nothing.
1030 Inlined.Table (Index).Processed := True;
1032 elsif Inlined.Table (Index).Main_Call then
1033 Pending_Inlined.Increment_Last;
1034 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
1035 Inlined.Table (Index).Processed := True;
1037 else
1038 Set_Is_Called (Inlined.Table (Index).Name, False);
1039 end if;
1040 end loop;
1042 -- Iterate over the workpile until it is emptied, propagating the
1043 -- Is_Called flag to the successors of the processed subprogram.
1045 while Pending_Inlined.Last >= Pending_Inlined.First loop
1046 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
1047 Pending_Inlined.Decrement_Last;
1049 S := Inlined.Table (Subp).First_Succ;
1051 while S /= No_Succ loop
1052 Subp := Successors.Table (S).Subp;
1054 if not Inlined.Table (Subp).Processed then
1055 Set_Is_Called (Inlined.Table (Subp).Name);
1056 Pending_Inlined.Increment_Last;
1057 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
1058 Inlined.Table (Subp).Processed := True;
1059 end if;
1061 S := Successors.Table (S).Next;
1062 end loop;
1063 end loop;
1065 -- Finally add the called subprograms to the list of inlined
1066 -- subprograms for the unit.
1068 for Index in Inlined.First .. Inlined.Last loop
1069 declare
1070 E : constant Subprogram_Kind_Id := Inlined.Table (Index).Name;
1072 begin
1073 if Is_Called (E) and then not Is_Ignored_Ghost_Entity (E) then
1074 Add_Inlined_Subprogram (E);
1075 end if;
1076 end;
1077 end loop;
1079 Pop_Scope;
1080 end if;
1081 end Analyze_Inlined_Bodies;
1083 --------------------------
1084 -- Build_Body_To_Inline --
1085 --------------------------
1087 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1088 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1089 Original_Body : Node_Id;
1090 Body_To_Analyze : Node_Id;
1091 Max_Size : constant := 10;
1093 function Has_Extended_Return return Boolean;
1094 -- This function returns True if the subprogram has an extended return
1095 -- statement.
1097 function Has_Pending_Instantiation return Boolean;
1098 -- If some enclosing body contains instantiations that appear before
1099 -- the corresponding generic body, the enclosing body has a freeze node
1100 -- so that it can be elaborated after the generic itself. This might
1101 -- conflict with subsequent inlinings, so that it is unsafe to try to
1102 -- inline in such a case.
1104 function Has_Single_Return_In_GNATprove_Mode return Boolean;
1105 -- This function is called only in GNATprove mode, and it returns
1106 -- True if the subprogram has no return statement or a single return
1107 -- statement as last statement. It returns False for subprogram with
1108 -- a single return as last statement inside one or more blocks, as
1109 -- inlining would generate gotos in that case as well (although the
1110 -- goto is useless in that case).
1112 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
1113 -- If the body of the subprogram includes a call that returns an
1114 -- unconstrained type, the secondary stack is involved, and it is
1115 -- not worth inlining.
1117 -------------------------
1118 -- Has_Extended_Return --
1119 -------------------------
1121 function Has_Extended_Return return Boolean is
1122 Body_To_Inline : constant Node_Id := N;
1124 function Check_Return (N : Node_Id) return Traverse_Result;
1125 -- Returns OK on node N if this is not an extended return statement
1127 ------------------
1128 -- Check_Return --
1129 ------------------
1131 function Check_Return (N : Node_Id) return Traverse_Result is
1132 begin
1133 case Nkind (N) is
1134 when N_Extended_Return_Statement =>
1135 return Abandon;
1137 -- Skip locally declared subprogram bodies inside the body to
1138 -- inline, as the return statements inside those do not count.
1140 when N_Subprogram_Body =>
1141 if N = Body_To_Inline then
1142 return OK;
1143 else
1144 return Skip;
1145 end if;
1147 when others =>
1148 return OK;
1149 end case;
1150 end Check_Return;
1152 function Check_All_Returns is new Traverse_Func (Check_Return);
1154 -- Start of processing for Has_Extended_Return
1156 begin
1157 return Check_All_Returns (N) /= OK;
1158 end Has_Extended_Return;
1160 -------------------------------
1161 -- Has_Pending_Instantiation --
1162 -------------------------------
1164 function Has_Pending_Instantiation return Boolean is
1165 S : Entity_Id;
1167 begin
1168 S := Current_Scope;
1169 while Present (S) loop
1170 if Is_Compilation_Unit (S)
1171 or else Is_Child_Unit (S)
1172 then
1173 return False;
1175 elsif Ekind (S) = E_Package
1176 and then Has_Forward_Instantiation (S)
1177 then
1178 return True;
1179 end if;
1181 S := Scope (S);
1182 end loop;
1184 return False;
1185 end Has_Pending_Instantiation;
1187 -----------------------------------------
1188 -- Has_Single_Return_In_GNATprove_Mode --
1189 -----------------------------------------
1191 function Has_Single_Return_In_GNATprove_Mode return Boolean is
1192 Body_To_Inline : constant Node_Id := N;
1193 Last_Statement : Node_Id := Empty;
1195 function Check_Return (N : Node_Id) return Traverse_Result;
1196 -- Returns OK on node N if this is not a return statement different
1197 -- from the last statement in the subprogram.
1199 ------------------
1200 -- Check_Return --
1201 ------------------
1203 function Check_Return (N : Node_Id) return Traverse_Result is
1204 begin
1205 case Nkind (N) is
1206 when N_Extended_Return_Statement
1207 | N_Simple_Return_Statement
1209 if N = Last_Statement then
1210 return OK;
1211 else
1212 return Abandon;
1213 end if;
1215 -- Skip locally declared subprogram bodies inside the body to
1216 -- inline, as the return statements inside those do not count.
1218 when N_Subprogram_Body =>
1219 if N = Body_To_Inline then
1220 return OK;
1221 else
1222 return Skip;
1223 end if;
1225 when others =>
1226 return OK;
1227 end case;
1228 end Check_Return;
1230 function Check_All_Returns is new Traverse_Func (Check_Return);
1232 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
1234 begin
1235 -- Retrieve the last statement
1237 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
1239 -- Check that the last statement is the only possible return
1240 -- statement in the subprogram.
1242 return Check_All_Returns (N) = OK;
1243 end Has_Single_Return_In_GNATprove_Mode;
1245 --------------------------
1246 -- Uses_Secondary_Stack --
1247 --------------------------
1249 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1250 function Check_Call (N : Node_Id) return Traverse_Result;
1251 -- Look for function calls that return an unconstrained type
1253 ----------------
1254 -- Check_Call --
1255 ----------------
1257 function Check_Call (N : Node_Id) return Traverse_Result is
1258 begin
1259 if Nkind (N) = N_Function_Call
1260 and then Is_Entity_Name (Name (N))
1261 and then Is_Composite_Type (Etype (Entity (Name (N))))
1262 and then not Is_Constrained (Etype (Entity (Name (N))))
1263 then
1264 Cannot_Inline
1265 ("cannot inline & (call returns unconstrained type)?",
1266 N, Spec_Id);
1267 return Abandon;
1268 else
1269 return OK;
1270 end if;
1271 end Check_Call;
1273 function Check_Calls is new Traverse_Func (Check_Call);
1275 begin
1276 return Check_Calls (Bod) = Abandon;
1277 end Uses_Secondary_Stack;
1279 -- Start of processing for Build_Body_To_Inline
1281 begin
1282 -- Return immediately if done already
1284 if Nkind (Decl) = N_Subprogram_Declaration
1285 and then Present (Body_To_Inline (Decl))
1286 then
1287 return;
1289 -- Subprograms that have return statements in the middle of the body are
1290 -- inlined with gotos. GNATprove does not currently support gotos, so
1291 -- we prevent such inlining.
1293 elsif GNATprove_Mode
1294 and then not Has_Single_Return_In_GNATprove_Mode
1295 then
1296 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1297 return;
1299 -- Functions that return controlled types cannot currently be inlined
1300 -- because they require secondary stack handling; controlled actions
1301 -- may also interfere in complex ways with inlining.
1303 elsif Ekind (Spec_Id) = E_Function
1304 and then Needs_Finalization (Etype (Spec_Id))
1305 then
1306 Cannot_Inline
1307 ("cannot inline & (controlled return type)?", N, Spec_Id);
1308 return;
1309 end if;
1311 if Has_Excluded_Declaration (Spec_Id, Declarations (N)) then
1312 return;
1313 end if;
1315 if Present (Handled_Statement_Sequence (N)) then
1316 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1317 Cannot_Inline
1318 ("cannot inline& (exception handler)?",
1319 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1320 Spec_Id);
1321 return;
1323 elsif Has_Excluded_Statement
1324 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1325 then
1326 return;
1327 end if;
1328 end if;
1330 -- We do not inline a subprogram that is too large, unless it is marked
1331 -- Inline_Always or we are in GNATprove mode. This pragma does not
1332 -- suppress the other checks on inlining (forbidden declarations,
1333 -- handlers, etc).
1335 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1336 and then List_Length
1337 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1338 then
1339 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1340 return;
1341 end if;
1343 if Has_Pending_Instantiation then
1344 Cannot_Inline
1345 ("cannot inline& (forward instance within enclosing body)?",
1346 N, Spec_Id);
1347 return;
1348 end if;
1350 -- Within an instance, the body to inline must be treated as a nested
1351 -- generic, so that the proper global references are preserved.
1353 -- Note that we do not do this at the library level, because it is not
1354 -- needed, and furthermore this causes trouble if front-end inlining
1355 -- is activated (-gnatN).
1357 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1358 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1359 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
1360 else
1361 Original_Body := Copy_Separate_Tree (N);
1362 end if;
1364 -- We need to capture references to the formals in order to substitute
1365 -- the actuals at the point of inlining, i.e. instantiation. To treat
1366 -- the formals as globals to the body to inline, we nest it within a
1367 -- dummy parameterless subprogram, declared within the real one. To
1368 -- avoid generating an internal name (which is never public, and which
1369 -- affects serial numbers of other generated names), we use an internal
1370 -- symbol that cannot conflict with user declarations.
1372 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1373 Set_Defining_Unit_Name
1374 (Specification (Original_Body),
1375 Make_Defining_Identifier (Sloc (N), Name_uParent));
1376 Set_Corresponding_Spec (Original_Body, Empty);
1378 -- Remove all aspects/pragmas that have no meaning in an inlined body
1380 Remove_Aspects_And_Pragmas (Original_Body);
1382 Body_To_Analyze :=
1383 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
1385 -- Set return type of function, which is also global and does not need
1386 -- to be resolved.
1388 if Ekind (Spec_Id) = E_Function then
1389 Set_Result_Definition
1390 (Specification (Body_To_Analyze),
1391 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1392 end if;
1394 if No (Declarations (N)) then
1395 Set_Declarations (N, New_List (Body_To_Analyze));
1396 else
1397 Append (Body_To_Analyze, Declarations (N));
1398 end if;
1400 Start_Generic;
1402 Analyze (Body_To_Analyze);
1403 Push_Scope (Defining_Entity (Body_To_Analyze));
1404 Save_Global_References (Original_Body);
1405 End_Scope;
1406 Remove (Body_To_Analyze);
1408 End_Generic;
1410 -- Restore environment if previously saved
1412 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1413 Restore_Env;
1414 end if;
1416 -- Functions that return unconstrained composite types require
1417 -- secondary stack handling, and cannot currently be inlined, unless
1418 -- all return statements return a local variable that is the first
1419 -- local declaration in the body. We had to delay this check until
1420 -- the body of the function is analyzed since Has_Single_Return()
1421 -- requires a minimum decoration.
1423 if Ekind (Spec_Id) = E_Function
1424 and then not Is_Scalar_Type (Etype (Spec_Id))
1425 and then not Is_Access_Type (Etype (Spec_Id))
1426 and then not Is_Constrained (Etype (Spec_Id))
1427 then
1428 if not Has_Single_Return (Body_To_Analyze)
1430 -- Skip inlining if the function returns an unconstrained type
1431 -- using an extended return statement, since this part of the
1432 -- new inlining model is not yet supported by the current
1433 -- implementation.
1435 or else (Returns_Unconstrained_Type (Spec_Id)
1436 and then Has_Extended_Return)
1437 then
1438 Cannot_Inline
1439 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1440 return;
1441 end if;
1443 -- If secondary stack is used, there is no point in inlining. We have
1444 -- already issued the warning in this case, so nothing to do.
1446 elsif Uses_Secondary_Stack (Body_To_Analyze) then
1447 return;
1448 end if;
1450 Set_Body_To_Inline (Decl, Original_Body);
1451 Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1452 Set_Is_Inlined (Spec_Id);
1453 end Build_Body_To_Inline;
1455 -------------------------------------------
1456 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1457 -------------------------------------------
1459 function Call_Can_Be_Inlined_In_GNATprove_Mode
1460 (N : Node_Id;
1461 Subp : Entity_Id) return Boolean
1463 F : Entity_Id;
1464 A : Node_Id;
1466 begin
1467 F := First_Formal (Subp);
1468 A := First_Actual (N);
1469 while Present (F) loop
1470 if Ekind (F) /= E_Out_Parameter
1471 and then not Same_Type (Etype (F), Etype (A))
1472 and then
1473 (Is_By_Reference_Type (Etype (A))
1474 or else Is_Limited_Type (Etype (A)))
1475 then
1476 return False;
1477 end if;
1479 Next_Formal (F);
1480 Next_Actual (A);
1481 end loop;
1483 return True;
1484 end Call_Can_Be_Inlined_In_GNATprove_Mode;
1486 --------------------------------------
1487 -- Can_Be_Inlined_In_GNATprove_Mode --
1488 --------------------------------------
1490 function Can_Be_Inlined_In_GNATprove_Mode
1491 (Spec_Id : Entity_Id;
1492 Body_Id : Entity_Id) return Boolean
1494 function Has_Formal_Or_Result_Of_Deep_Type
1495 (Id : Entity_Id) return Boolean;
1496 -- Returns true if the subprogram has at least one formal parameter or
1497 -- a return type of a deep type: either an access type or a composite
1498 -- type containing an access type.
1500 function Has_Formal_With_Discriminant_Dependent_Fields
1501 (Id : Entity_Id) return Boolean;
1502 -- Returns true if the subprogram has at least one formal parameter of
1503 -- an unconstrained record type with per-object constraints on component
1504 -- types.
1506 function Has_Skip_Proof_Annotation (Id : Entity_Id) return Boolean;
1507 -- Returns True if subprogram Id has an annotation Skip_Proof or
1508 -- Skip_Flow_And_Proof.
1510 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1511 -- Return True if subprogram Id has any contract. The presence of
1512 -- Extensions_Visible or Volatile_Function is also considered as a
1513 -- contract here.
1515 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1516 -- Return True if subprogram Id defines a compilation unit
1518 function In_Package_Spec (Id : Entity_Id) return Boolean;
1519 -- Return True if subprogram Id is defined in the package specification,
1520 -- either its visible or private part.
1522 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean;
1523 -- Return True if subprogram Id could be a traversal function, as
1524 -- defined in SPARK RM 3.10. This is only a safe approximation, as the
1525 -- knowledge of the SPARK boundary is needed to determine exactly
1526 -- traversal functions.
1528 ---------------------------------------
1529 -- Has_Formal_Or_Result_Of_Deep_Type --
1530 ---------------------------------------
1532 function Has_Formal_Or_Result_Of_Deep_Type
1533 (Id : Entity_Id) return Boolean
1535 function Is_Deep (Typ : Entity_Id) return Boolean;
1536 -- Return True if Typ is deep: either an access type or a composite
1537 -- type containing an access type.
1539 -------------
1540 -- Is_Deep --
1541 -------------
1543 function Is_Deep (Typ : Entity_Id) return Boolean is
1544 begin
1545 case Type_Kind'(Ekind (Typ)) is
1546 when Access_Kind =>
1547 return True;
1549 when E_Array_Type
1550 | E_Array_Subtype
1552 return Is_Deep (Component_Type (Typ));
1554 when Record_Kind =>
1555 declare
1556 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
1557 begin
1558 while Present (Comp) loop
1559 if Is_Deep (Etype (Comp)) then
1560 return True;
1561 end if;
1562 Next_Component_Or_Discriminant (Comp);
1563 end loop;
1564 end;
1565 return False;
1567 when Scalar_Kind
1568 | E_String_Literal_Subtype
1569 | Concurrent_Kind
1570 | Incomplete_Kind
1571 | E_Exception_Type
1572 | E_Subprogram_Type
1574 return False;
1576 when E_Private_Type
1577 | E_Private_Subtype
1578 | E_Limited_Private_Type
1579 | E_Limited_Private_Subtype
1581 -- Conservatively consider that the type might be deep if
1582 -- its completion has not been seen yet.
1584 if No (Underlying_Type (Typ)) then
1585 return True;
1587 -- Do not peek under a private type if its completion has
1588 -- SPARK_Mode Off. In such a case, a deep type is considered
1589 -- by GNATprove to be not deep.
1591 elsif Present (Full_View (Typ))
1592 and then Present (SPARK_Pragma (Full_View (Typ)))
1593 and then Get_SPARK_Mode_From_Annotation
1594 (SPARK_Pragma (Full_View (Typ))) = Off
1595 then
1596 return False;
1598 -- Otherwise peek under the private type.
1600 else
1601 return Is_Deep (Underlying_Type (Typ));
1602 end if;
1603 end case;
1604 end Is_Deep;
1606 -- Local variables
1608 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1609 Formal : Entity_Id;
1610 Formal_Typ : Entity_Id;
1612 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
1614 begin
1615 -- Inspect all parameters of the subprogram looking for a formal
1616 -- of a deep type.
1618 Formal := First_Formal (Subp_Id);
1619 while Present (Formal) loop
1620 Formal_Typ := Etype (Formal);
1622 if Is_Deep (Formal_Typ) then
1623 return True;
1624 end if;
1626 Next_Formal (Formal);
1627 end loop;
1629 -- Check whether this is a function whose return type is deep
1631 if Ekind (Subp_Id) = E_Function
1632 and then Is_Deep (Etype (Subp_Id))
1633 then
1634 return True;
1635 end if;
1637 return False;
1638 end Has_Formal_Or_Result_Of_Deep_Type;
1640 ---------------------------------------------------
1641 -- Has_Formal_With_Discriminant_Dependent_Fields --
1642 ---------------------------------------------------
1644 function Has_Formal_With_Discriminant_Dependent_Fields
1645 (Id : Entity_Id) return Boolean
1647 function Has_Discriminant_Dependent_Component
1648 (Typ : Entity_Id) return Boolean;
1649 -- Determine whether unconstrained record type Typ has at least one
1650 -- component that depends on a discriminant.
1652 ------------------------------------------
1653 -- Has_Discriminant_Dependent_Component --
1654 ------------------------------------------
1656 function Has_Discriminant_Dependent_Component
1657 (Typ : Entity_Id) return Boolean
1659 Comp : Entity_Id;
1661 begin
1662 -- Inspect all components of the record type looking for one that
1663 -- depends on a discriminant.
1665 Comp := First_Component (Typ);
1666 while Present (Comp) loop
1667 if Has_Discriminant_Dependent_Constraint (Comp) then
1668 return True;
1669 end if;
1671 Next_Component (Comp);
1672 end loop;
1674 return False;
1675 end Has_Discriminant_Dependent_Component;
1677 -- Local variables
1679 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1680 Formal : Entity_Id;
1681 Formal_Typ : Entity_Id;
1683 -- Start of processing for
1684 -- Has_Formal_With_Discriminant_Dependent_Fields
1686 begin
1687 -- Inspect all parameters of the subprogram looking for a formal
1688 -- of an unconstrained record type with at least one discriminant
1689 -- dependent component.
1691 Formal := First_Formal (Subp_Id);
1692 while Present (Formal) loop
1693 Formal_Typ := Etype (Formal);
1695 if Is_Record_Type (Formal_Typ)
1696 and then not Is_Constrained (Formal_Typ)
1697 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1698 then
1699 return True;
1700 end if;
1702 Next_Formal (Formal);
1703 end loop;
1705 return False;
1706 end Has_Formal_With_Discriminant_Dependent_Fields;
1708 -------------------------------
1709 -- Has_Skip_Proof_Annotation --
1710 -------------------------------
1712 function Has_Skip_Proof_Annotation (Id : Entity_Id) return Boolean is
1713 Decl : Node_Id := Unit_Declaration_Node (Id);
1715 begin
1716 Next (Decl);
1718 while Present (Decl)
1719 and then Nkind (Decl) = N_Pragma
1720 loop
1721 if Get_Pragma_Id (Decl) = Pragma_Annotate
1722 and then List_Length (Pragma_Argument_Associations (Decl)) = 3
1723 then
1724 declare
1725 Arg1 : constant Node_Id :=
1726 First (Pragma_Argument_Associations (Decl));
1727 Arg2 : constant Node_Id := Next (Arg1);
1728 Arg1_Name : constant String :=
1729 Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
1730 Arg2_Name : constant String :=
1731 Get_Name_String (Chars (Get_Pragma_Arg (Arg2)));
1732 begin
1733 if Arg1_Name = "gnatprove"
1734 and then Arg2_Name in "skip_proof" | "skip_flow_and_proof"
1735 then
1736 return True;
1737 end if;
1738 end;
1739 end if;
1741 Next (Decl);
1742 end loop;
1744 return False;
1745 end Has_Skip_Proof_Annotation;
1747 -----------------------
1748 -- Has_Some_Contract --
1749 -----------------------
1751 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1752 Items : Node_Id;
1754 begin
1755 -- A call to an expression function may precede the actual body which
1756 -- is inserted at the end of the enclosing declarations. Ensure that
1757 -- the related entity is decorated before inspecting the contract.
1759 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1760 Items := Contract (Id);
1762 -- Note that Classifications is not Empty when Extensions_Visible
1763 -- or Volatile_Function is present, which causes such subprograms
1764 -- to be considered to have a contract here. This is fine as we
1765 -- want to avoid inlining these too.
1767 return Present (Items)
1768 and then (Present (Pre_Post_Conditions (Items)) or else
1769 Present (Contract_Test_Cases (Items)) or else
1770 Present (Classifications (Items)));
1771 end if;
1773 return False;
1774 end Has_Some_Contract;
1776 ---------------------
1777 -- In_Package_Spec --
1778 ---------------------
1780 function In_Package_Spec (Id : Entity_Id) return Boolean is
1781 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1782 -- Parent of the subprogram's declaration
1784 begin
1785 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1786 end In_Package_Spec;
1788 ------------------------
1789 -- Is_Unit_Subprogram --
1790 ------------------------
1792 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1793 Decl : Node_Id := Parent (Parent (Id));
1794 begin
1795 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1796 Decl := Parent (Decl);
1797 end if;
1799 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1800 end Is_Unit_Subprogram;
1802 ------------------------------
1803 -- Maybe_Traversal_Function --
1804 ------------------------------
1806 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
1807 begin
1808 return Ekind (Id) = E_Function
1810 -- Only traversal functions return an anonymous access-to-object
1811 -- type in SPARK.
1813 and then Is_Anonymous_Access_Type (Etype (Id));
1814 end Maybe_Traversal_Function;
1816 -- Local declarations
1818 Id : Entity_Id;
1819 -- Procedure or function entity for the subprogram
1821 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1823 begin
1824 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1826 if Present (Spec_Id) then
1827 Id := Spec_Id;
1828 else
1829 Id := Body_Id;
1830 end if;
1832 -- Only local subprograms without contracts are inlined in GNATprove
1833 -- mode, as these are the subprograms which a user is not interested in
1834 -- analyzing in isolation, but rather in the context of their call. This
1835 -- is a convenient convention, that could be changed for an explicit
1836 -- pragma/aspect one day.
1838 -- In a number of special cases, inlining is not desirable or not
1839 -- possible, see below.
1841 -- Do not inline unit-level subprograms
1843 if Is_Unit_Subprogram (Id) then
1844 return False;
1846 -- Do not inline subprograms declared in package specs, because they are
1847 -- not local, i.e. can be called either from anywhere (if declared in
1848 -- visible part) or from the child units (if declared in private part).
1850 elsif In_Package_Spec (Id) then
1851 return False;
1853 -- Do not inline subprograms declared in other units. This is important
1854 -- in particular for subprograms defined in the private part of a
1855 -- package spec, when analyzing one of its child packages, as otherwise
1856 -- we issue spurious messages about the impossibility to inline such
1857 -- calls.
1859 elsif not In_Extended_Main_Code_Unit (Id) then
1860 return False;
1862 -- Do not inline dispatching operations, as only their static calls
1863 -- can be analyzed in context, and not their dispatching calls.
1865 elsif Is_Dispatching_Operation (Id) then
1866 return False;
1868 -- Do not inline subprograms marked No_Return, possibly used for
1869 -- signaling errors, which GNATprove handles specially.
1871 elsif No_Return (Id) then
1872 return False;
1874 -- Do not inline subprograms that have a contract on the spec or the
1875 -- body. Use the contract(s) instead in GNATprove. This also prevents
1876 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
1878 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1879 or else
1880 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1881 then
1882 return False;
1884 -- Do not inline expression functions, which are directly inlined at the
1885 -- prover level.
1887 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1888 or else
1889 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1890 then
1891 return False;
1893 -- Do not inline generic subprogram instances. The visibility rules of
1894 -- generic instances plays badly with inlining.
1896 elsif Is_Generic_Instance (Spec_Id) then
1897 return False;
1899 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1900 -- the subprogram body, a similar check is performed after the body
1901 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1903 elsif Present (Spec_Id)
1904 and then
1905 (No (SPARK_Pragma (Spec_Id))
1906 or else
1907 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1908 then
1909 return False;
1911 -- Do not inline subprograms and entries defined inside protected types,
1912 -- which typically are not helper subprograms, which also avoids getting
1913 -- spurious messages on calls that cannot be inlined.
1915 elsif Within_Protected_Type (Id) then
1916 return False;
1918 -- Do not inline predicate functions (treated specially by GNATprove)
1920 elsif Is_Predicate_Function (Id) then
1921 return False;
1923 -- Do not inline subprograms with a parameter of an unconstrained
1924 -- record type if it has discrimiant dependent fields. Indeed, with
1925 -- such parameters, the frontend cannot always ensure type compliance
1926 -- in record component accesses (in particular with records containing
1927 -- packed arrays).
1929 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1930 return False;
1932 -- Do not inline subprograms with a formal parameter or return type of
1933 -- a deep type, as in that case inlining might generate code that
1934 -- violates borrow-checking rules of SPARK 3.10 even if the original
1935 -- code did not.
1937 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
1938 return False;
1940 -- Do not inline subprograms which may be traversal functions. Such
1941 -- inlining introduces temporary variables of named access type for
1942 -- which assignments are move instead of borrow/observe, possibly
1943 -- leading to spurious errors when checking SPARK rules related to
1944 -- pointer usage.
1946 elsif Maybe_Traversal_Function (Id) then
1947 return False;
1949 -- Do not inline subprograms with the Skip_Proof or Skip_Flow_And_Proof
1950 -- annotation, which should be handled separately.
1952 elsif Has_Skip_Proof_Annotation (Id) then
1953 return False;
1955 -- Otherwise, this is a subprogram declared inside the private part of a
1956 -- package, or inside a package body, or locally in a subprogram, and it
1957 -- does not have any contract. Inline it.
1959 else
1960 return True;
1961 end if;
1962 end Can_Be_Inlined_In_GNATprove_Mode;
1964 -------------------
1965 -- Cannot_Inline --
1966 -------------------
1968 procedure Cannot_Inline
1969 (Msg : String;
1970 N : Node_Id;
1971 Subp : Entity_Id;
1972 Is_Serious : Boolean := False;
1973 Suppress_Info : Boolean := False)
1975 begin
1976 -- In GNATprove mode, inlining is the technical means by which the
1977 -- higher-level goal of contextual analysis is reached, so issue
1978 -- messages about failure to apply contextual analysis to a
1979 -- subprogram, rather than failure to inline it.
1981 if GNATprove_Mode
1982 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1983 then
1984 declare
1985 Len1 : constant Positive :=
1986 String (String'("cannot inline"))'Length;
1987 Len2 : constant Positive :=
1988 String (String'("info: no contextual analysis of"))'Length;
1990 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1992 begin
1993 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1994 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1995 Msg (Msg'First + Len1 .. Msg'Last);
1996 Cannot_Inline (New_Msg, N, Subp, Is_Serious, Suppress_Info);
1997 return;
1998 end;
1999 end if;
2001 pragma Assert (Msg (Msg'Last) = '?');
2003 -- Legacy front-end inlining model
2005 if not Back_End_Inlining then
2007 -- Do not emit warning if this is a predefined unit which is not
2008 -- the main unit. With validity checks enabled, some predefined
2009 -- subprograms may contain nested subprograms and become ineligible
2010 -- for inlining.
2012 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2013 and then not In_Extended_Main_Source_Unit (Subp)
2014 then
2015 null;
2017 -- In GNATprove mode, issue an info message when -gnatd_f is set and
2018 -- Suppress_Info is False, and indicate that the subprogram is not
2019 -- always inlined by setting flag Is_Inlined_Always to False.
2021 elsif GNATprove_Mode then
2022 Set_Is_Inlined_Always (Subp, False);
2024 if Debug_Flag_Underscore_F and not Suppress_Info then
2025 Error_Msg_NE (Msg, N, Subp);
2026 end if;
2028 elsif Has_Pragma_Inline_Always (Subp) then
2030 -- Remove last character (question mark) to make this into an
2031 -- error, because the Inline_Always pragma cannot be obeyed.
2033 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2035 elsif Ineffective_Inline_Warnings then
2036 Error_Msg_NE (Msg & "p?", N, Subp);
2037 end if;
2039 -- New semantics relying on back-end inlining
2041 elsif Is_Serious then
2043 -- Remove last character (question mark) to make this into an error.
2045 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2047 -- In GNATprove mode, issue an info message when -gnatd_f is set and
2048 -- Suppress_Info is False, and indicate that the subprogram is not
2049 -- always inlined by setting flag Is_Inlined_Always to False.
2051 elsif GNATprove_Mode then
2052 Set_Is_Inlined_Always (Subp, False);
2054 if Debug_Flag_Underscore_F and not Suppress_Info then
2055 Error_Msg_NE (Msg, N, Subp);
2056 end if;
2058 else
2060 -- Do not emit warning if this is a predefined unit which is not
2061 -- the main unit. This behavior is currently provided for backward
2062 -- compatibility but it will be removed when we enforce the
2063 -- strictness of the new rules.
2065 if Is_Predefined_Unit (Get_Source_Unit (Subp))
2066 and then not In_Extended_Main_Source_Unit (Subp)
2067 then
2068 null;
2070 elsif Has_Pragma_Inline_Always (Subp) then
2072 -- Emit a warning if this is a call to a runtime subprogram
2073 -- which is located inside a generic. Previously this call
2074 -- was silently skipped.
2076 if Is_Generic_Instance (Subp) then
2077 declare
2078 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
2079 begin
2080 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
2081 Set_Is_Inlined (Subp, False);
2082 Error_Msg_NE (Msg & "p?", N, Subp);
2083 return;
2084 end if;
2085 end;
2086 end if;
2088 -- Remove last character (question mark) to make this into an
2089 -- error, because the Inline_Always pragma cannot be obeyed.
2091 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2093 else
2094 Set_Is_Inlined (Subp, False);
2096 if Ineffective_Inline_Warnings then
2097 Error_Msg_NE (Msg & "p?", N, Subp);
2098 end if;
2099 end if;
2100 end if;
2101 end Cannot_Inline;
2103 --------------------------------------------
2104 -- Check_And_Split_Unconstrained_Function --
2105 --------------------------------------------
2107 procedure Check_And_Split_Unconstrained_Function
2108 (N : Node_Id;
2109 Spec_Id : Entity_Id;
2110 Body_Id : Entity_Id)
2112 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
2113 -- Use generic machinery to build an unexpanded body for the subprogram.
2114 -- This body is subsequently used for inline expansions at call sites.
2116 procedure Build_Return_Object_Formal
2117 (Loc : Source_Ptr;
2118 Obj_Decl : Node_Id;
2119 Formals : List_Id);
2120 -- Create a formal parameter for return object declaration Obj_Decl of
2121 -- an extended return statement and add it to list Formals.
2123 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
2124 -- Return true if we generate code for the function body N, the function
2125 -- body N has no local declarations and its unique statement is a single
2126 -- extended return statement with a handled statements sequence.
2128 procedure Copy_Formals
2129 (Loc : Source_Ptr;
2130 Subp_Id : Entity_Id;
2131 Formals : List_Id);
2132 -- Create new formal parameters from the formal parameters of subprogram
2133 -- Subp_Id and add them to list Formals.
2135 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
2136 -- Create a copy of return object declaration Obj_Decl of an extended
2137 -- return statement.
2139 procedure Split_Unconstrained_Function
2140 (N : Node_Id;
2141 Spec_Id : Entity_Id);
2142 -- N is an inlined function body that returns an unconstrained type and
2143 -- has a single extended return statement. Split N in two subprograms:
2144 -- a procedure P' and a function F'. The formals of P' duplicate the
2145 -- formals of N plus an extra formal which is used to return a value;
2146 -- its body is composed by the declarations and list of statements
2147 -- of the extended return statement of N.
2149 --------------------------
2150 -- Build_Body_To_Inline --
2151 --------------------------
2153 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
2154 procedure Generate_Subprogram_Body
2155 (N : Node_Id;
2156 Body_To_Inline : out Node_Id);
2157 -- Generate a parameterless duplicate of subprogram body N. Note that
2158 -- occurrences of pragmas referencing the formals are removed since
2159 -- they have no meaning when the body is inlined and the formals are
2160 -- rewritten (the analysis of the non-inlined body will handle these
2161 -- pragmas). A new internal name is associated with Body_To_Inline.
2163 ------------------------------
2164 -- Generate_Subprogram_Body --
2165 ------------------------------
2167 procedure Generate_Subprogram_Body
2168 (N : Node_Id;
2169 Body_To_Inline : out Node_Id)
2171 begin
2172 -- Within an instance, the body to inline must be treated as a
2173 -- nested generic so that proper global references are preserved.
2175 -- Note that we do not do this at the library level, because it
2176 -- is not needed, and furthermore this causes trouble if front
2177 -- end inlining is activated (-gnatN).
2179 if In_Instance
2180 and then Scope (Current_Scope) /= Standard_Standard
2181 then
2182 Body_To_Inline :=
2183 Copy_Generic_Node (N, Empty, Instantiating => True);
2184 else
2185 Body_To_Inline := New_Copy_Tree (N);
2186 end if;
2188 -- Remove aspects/pragmas that have no meaning in an inlined body
2190 Remove_Aspects_And_Pragmas (Body_To_Inline);
2192 -- We need to capture references to the formals in order
2193 -- to substitute the actuals at the point of inlining, i.e.
2194 -- instantiation. To treat the formals as globals to the body to
2195 -- inline, we nest it within a dummy parameterless subprogram,
2196 -- declared within the real one.
2198 Set_Parameter_Specifications
2199 (Specification (Body_To_Inline), No_List);
2201 -- A new internal name is associated with Body_To_Inline to avoid
2202 -- conflicts when the non-inlined body N is analyzed.
2204 Set_Defining_Unit_Name (Specification (Body_To_Inline),
2205 Make_Temporary (Sloc (N), 'P'));
2206 Set_Corresponding_Spec (Body_To_Inline, Empty);
2207 end Generate_Subprogram_Body;
2209 -- Local variables
2211 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2212 Original_Body : Node_Id;
2213 Body_To_Analyze : Node_Id;
2215 -- Start of processing for Build_Body_To_Inline
2217 begin
2218 pragma Assert (Current_Scope = Spec_Id);
2220 -- Within an instance, the body to inline must be treated as a nested
2221 -- generic, so that the proper global references are preserved. We
2222 -- do not do this at the library level, because it is not needed, and
2223 -- furthermore this causes trouble if front-end inlining is activated
2224 -- (-gnatN).
2226 if In_Instance
2227 and then Scope (Current_Scope) /= Standard_Standard
2228 then
2229 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2230 end if;
2232 -- Capture references to formals in order to substitute the actuals
2233 -- at the point of inlining or instantiation. To treat the formals
2234 -- as globals to the body to inline, nest the body within a dummy
2235 -- parameterless subprogram, declared within the real one.
2237 Generate_Subprogram_Body (N, Original_Body);
2238 Body_To_Analyze :=
2239 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
2241 -- Set return type of function, which is also global and does not
2242 -- need to be resolved.
2244 if Ekind (Spec_Id) = E_Function then
2245 Set_Result_Definition (Specification (Body_To_Analyze),
2246 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
2247 end if;
2249 if No (Declarations (N)) then
2250 Set_Declarations (N, New_List (Body_To_Analyze));
2251 else
2252 Append_To (Declarations (N), Body_To_Analyze);
2253 end if;
2255 Preanalyze (Body_To_Analyze);
2257 Push_Scope (Defining_Entity (Body_To_Analyze));
2258 Save_Global_References (Original_Body);
2259 End_Scope;
2260 Remove (Body_To_Analyze);
2262 -- Restore environment if previously saved
2264 if In_Instance
2265 and then Scope (Current_Scope) /= Standard_Standard
2266 then
2267 Restore_Env;
2268 end if;
2270 pragma Assert (No (Body_To_Inline (Decl)));
2271 Set_Body_To_Inline (Decl, Original_Body);
2272 Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
2273 end Build_Body_To_Inline;
2275 --------------------------------
2276 -- Build_Return_Object_Formal --
2277 --------------------------------
2279 procedure Build_Return_Object_Formal
2280 (Loc : Source_Ptr;
2281 Obj_Decl : Node_Id;
2282 Formals : List_Id)
2284 Obj_Def : constant Node_Id := Object_Definition (Obj_Decl);
2285 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2286 Typ_Def : Node_Id;
2288 begin
2289 -- Build the type definition of the formal parameter. The use of
2290 -- New_Copy_Tree ensures that global references preserved in the
2291 -- case of generics.
2293 if Is_Entity_Name (Obj_Def) then
2294 Typ_Def := New_Copy_Tree (Obj_Def);
2295 else
2296 Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
2297 end if;
2299 -- Generate:
2301 -- Obj_Id : [out] Typ_Def
2303 -- Mode OUT should not be used when the return object is declared as
2304 -- a constant. Check the definition of the object declaration because
2305 -- the object has not been analyzed yet.
2307 Append_To (Formals,
2308 Make_Parameter_Specification (Loc,
2309 Defining_Identifier =>
2310 Make_Defining_Identifier (Loc, Chars (Obj_Id)),
2311 In_Present => False,
2312 Out_Present => not Constant_Present (Obj_Decl),
2313 Null_Exclusion_Present => False,
2314 Parameter_Type => Typ_Def));
2315 end Build_Return_Object_Formal;
2317 --------------------------------------
2318 -- Can_Split_Unconstrained_Function --
2319 --------------------------------------
2321 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
2322 Stmt : constant Node_Id :=
2323 First (Statements (Handled_Statement_Sequence (N)));
2324 Decl : Node_Id;
2326 begin
2327 -- No user defined declarations allowed in the function except inside
2328 -- the unique return statement; implicit labels are the only allowed
2329 -- declarations.
2331 Decl := First (Declarations (N));
2332 while Present (Decl) loop
2333 if Nkind (Decl) /= N_Implicit_Label_Declaration then
2334 return False;
2335 end if;
2337 Next (Decl);
2338 end loop;
2340 -- We only split the inlined function when we are generating the code
2341 -- of its body; otherwise we leave duplicated split subprograms in
2342 -- the tree which (if referenced) generate wrong references at link
2343 -- time.
2345 return In_Extended_Main_Code_Unit (N)
2346 and then Present (Stmt)
2347 and then Nkind (Stmt) = N_Extended_Return_Statement
2348 and then No (Next (Stmt))
2349 and then Present (Handled_Statement_Sequence (Stmt));
2350 end Can_Split_Unconstrained_Function;
2352 ------------------
2353 -- Copy_Formals --
2354 ------------------
2356 procedure Copy_Formals
2357 (Loc : Source_Ptr;
2358 Subp_Id : Entity_Id;
2359 Formals : List_Id)
2361 Formal : Entity_Id;
2362 Spec : Node_Id;
2364 begin
2365 Formal := First_Formal (Subp_Id);
2366 while Present (Formal) loop
2367 Spec := Parent (Formal);
2369 -- Create an exact copy of the formal parameter. The use of
2370 -- New_Copy_Tree ensures that global references are preserved
2371 -- in case of generics.
2373 Append_To (Formals,
2374 Make_Parameter_Specification (Loc,
2375 Defining_Identifier =>
2376 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
2377 In_Present => In_Present (Spec),
2378 Out_Present => Out_Present (Spec),
2379 Null_Exclusion_Present => Null_Exclusion_Present (Spec),
2380 Parameter_Type =>
2381 New_Copy_Tree (Parameter_Type (Spec)),
2382 Expression => New_Copy_Tree (Expression (Spec))));
2384 Next_Formal (Formal);
2385 end loop;
2386 end Copy_Formals;
2388 ------------------------
2389 -- Copy_Return_Object --
2390 ------------------------
2392 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
2393 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2395 begin
2396 -- The use of New_Copy_Tree ensures that global references are
2397 -- preserved in case of generics.
2399 return
2400 Make_Object_Declaration (Sloc (Obj_Decl),
2401 Defining_Identifier =>
2402 Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)),
2403 Aliased_Present => Aliased_Present (Obj_Decl),
2404 Constant_Present => Constant_Present (Obj_Decl),
2405 Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl),
2406 Object_Definition =>
2407 New_Copy_Tree (Object_Definition (Obj_Decl)),
2408 Expression => New_Copy_Tree (Expression (Obj_Decl)));
2409 end Copy_Return_Object;
2411 ----------------------------------
2412 -- Split_Unconstrained_Function --
2413 ----------------------------------
2415 procedure Split_Unconstrained_Function
2416 (N : Node_Id;
2417 Spec_Id : Entity_Id)
2419 Loc : constant Source_Ptr := Sloc (N);
2420 Ret_Stmt : constant Node_Id :=
2421 First (Statements (Handled_Statement_Sequence (N)));
2422 Ret_Obj : constant Node_Id :=
2423 First (Return_Object_Declarations (Ret_Stmt));
2425 procedure Build_Procedure
2426 (Proc_Id : out Entity_Id;
2427 Decl_List : out List_Id);
2428 -- Build a procedure containing the statements found in the extended
2429 -- return statement of the unconstrained function body N.
2431 ---------------------
2432 -- Build_Procedure --
2433 ---------------------
2435 procedure Build_Procedure
2436 (Proc_Id : out Entity_Id;
2437 Decl_List : out List_Id)
2439 Formals : constant List_Id := New_List;
2440 Subp_Name : constant Name_Id := New_Internal_Name ('F');
2442 Body_Decls : List_Id := No_List;
2443 Decl : Node_Id;
2444 Proc_Body : Node_Id;
2445 Proc_Spec : Node_Id;
2447 begin
2448 -- Create formal parameters for the return object and all formals
2449 -- of the unconstrained function in order to pass their values to
2450 -- the procedure.
2452 Build_Return_Object_Formal
2453 (Loc => Loc,
2454 Obj_Decl => Ret_Obj,
2455 Formals => Formals);
2457 Copy_Formals
2458 (Loc => Loc,
2459 Subp_Id => Spec_Id,
2460 Formals => Formals);
2462 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
2464 Proc_Spec :=
2465 Make_Procedure_Specification (Loc,
2466 Defining_Unit_Name => Proc_Id,
2467 Parameter_Specifications => Formals);
2469 Decl_List := New_List;
2471 Append_To (Decl_List,
2472 Make_Subprogram_Declaration (Loc, Proc_Spec));
2474 -- Can_Convert_Unconstrained_Function checked that the function
2475 -- has no local declarations except implicit label declarations.
2476 -- Copy these declarations to the built procedure.
2478 if Present (Declarations (N)) then
2479 Body_Decls := New_List;
2481 Decl := First (Declarations (N));
2482 while Present (Decl) loop
2483 pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
2485 Append_To (Body_Decls,
2486 Make_Implicit_Label_Declaration (Loc,
2487 Make_Defining_Identifier (Loc,
2488 Chars => Chars (Defining_Identifier (Decl))),
2489 Label_Construct => Empty));
2491 Next (Decl);
2492 end loop;
2493 end if;
2495 pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
2497 Proc_Body :=
2498 Make_Subprogram_Body (Loc,
2499 Specification => Copy_Subprogram_Spec (Proc_Spec),
2500 Declarations => Body_Decls,
2501 Handled_Statement_Sequence =>
2502 New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
2504 Set_Defining_Unit_Name (Specification (Proc_Body),
2505 Make_Defining_Identifier (Loc, Subp_Name));
2507 Append_To (Decl_List, Proc_Body);
2508 end Build_Procedure;
2510 -- Local variables
2512 New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj);
2513 Blk_Stmt : Node_Id;
2514 Proc_Call : Node_Id;
2515 Proc_Id : Entity_Id;
2517 -- Start of processing for Split_Unconstrained_Function
2519 begin
2520 -- Build the associated procedure, analyze it and insert it before
2521 -- the function body N.
2523 declare
2524 Scope : constant Entity_Id := Current_Scope;
2525 Decl_List : List_Id;
2526 begin
2527 Pop_Scope;
2528 Build_Procedure (Proc_Id, Decl_List);
2529 Insert_Actions (N, Decl_List);
2530 Set_Is_Inlined (Proc_Id);
2531 Push_Scope (Scope);
2532 end;
2534 -- Build the call to the generated procedure
2536 declare
2537 Actual_List : constant List_Id := New_List;
2538 Formal : Entity_Id;
2540 begin
2541 Append_To (Actual_List,
2542 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
2544 Formal := First_Formal (Spec_Id);
2545 while Present (Formal) loop
2546 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
2548 -- Avoid spurious warning on unreferenced formals
2550 Set_Referenced (Formal);
2551 Next_Formal (Formal);
2552 end loop;
2554 Proc_Call :=
2555 Make_Procedure_Call_Statement (Loc,
2556 Name => New_Occurrence_Of (Proc_Id, Loc),
2557 Parameter_Associations => Actual_List);
2558 end;
2560 -- Generate:
2562 -- declare
2563 -- New_Obj : ...
2564 -- begin
2565 -- Proc (New_Obj, ...);
2566 -- return New_Obj;
2567 -- end;
2569 Blk_Stmt :=
2570 Make_Block_Statement (Loc,
2571 Declarations => New_List (New_Obj),
2572 Handled_Statement_Sequence =>
2573 Make_Handled_Sequence_Of_Statements (Loc,
2574 Statements => New_List (
2576 Proc_Call,
2578 Make_Simple_Return_Statement (Loc,
2579 Expression =>
2580 New_Occurrence_Of
2581 (Defining_Identifier (New_Obj), Loc)))));
2583 Rewrite (Ret_Stmt, Blk_Stmt);
2584 end Split_Unconstrained_Function;
2586 -- Local variables
2588 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2590 -- Start of processing for Check_And_Split_Unconstrained_Function
2592 begin
2593 pragma Assert (Back_End_Inlining
2594 and then Ekind (Spec_Id) = E_Function
2595 and then Returns_Unconstrained_Type (Spec_Id)
2596 and then Comes_From_Source (Body_Id)
2597 and then (Has_Pragma_Inline_Always (Spec_Id)
2598 or else Optimization_Level > 0));
2600 -- This routine must not be used in GNATprove mode since GNATprove
2601 -- relies on frontend inlining
2603 pragma Assert (not GNATprove_Mode);
2605 -- No need to split the function if we cannot generate the code
2607 if Serious_Errors_Detected /= 0 then
2608 return;
2609 end if;
2611 -- No action needed in stubs since the attribute Body_To_Inline
2612 -- is not available
2614 if Nkind (Decl) = N_Subprogram_Body_Stub then
2615 return;
2617 -- Cannot build the body to inline if the attribute is already set.
2618 -- This attribute may have been set if this is a subprogram renaming
2619 -- declarations (see Freeze.Build_Renamed_Body).
2621 elsif Present (Body_To_Inline (Decl)) then
2622 return;
2624 -- Do not generate a body to inline for protected functions, because the
2625 -- transformation generates a call to a protected procedure, causing
2626 -- spurious errors. We don't inline protected operations anyway, so
2627 -- this is no loss. We might as well ignore intrinsics and foreign
2628 -- conventions as well -- just allow Ada conventions.
2630 elsif not (Convention (Spec_Id) = Convention_Ada
2631 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Copy
2632 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Reference)
2633 then
2634 return;
2636 -- Check excluded declarations
2638 elsif Has_Excluded_Declaration (Spec_Id, Declarations (N)) then
2639 return;
2641 -- Check excluded statements. There is no need to protect us against
2642 -- exception handlers since they are supported by the GCC backend.
2644 elsif Present (Handled_Statement_Sequence (N))
2645 and then Has_Excluded_Statement
2646 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2647 then
2648 return;
2649 end if;
2651 -- Build the body to inline only if really needed
2653 if Can_Split_Unconstrained_Function (N) then
2654 Split_Unconstrained_Function (N, Spec_Id);
2655 Build_Body_To_Inline (N, Spec_Id);
2656 Set_Is_Inlined (Spec_Id);
2657 end if;
2658 end Check_And_Split_Unconstrained_Function;
2660 ---------------------------------------------
2661 -- Check_Object_Renaming_In_GNATprove_Mode --
2662 ---------------------------------------------
2664 procedure Check_Object_Renaming_In_GNATprove_Mode (Spec_Id : Entity_Id) is
2665 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2666 Body_Decl : constant Node_Id :=
2667 Unit_Declaration_Node (Corresponding_Body (Decl));
2669 function Check_Object_Renaming (N : Node_Id) return Traverse_Result;
2670 -- Returns Abandon on node N if this is a reference to an object
2671 -- renaming, which will be expanded into the renamed object in
2672 -- GNATprove mode.
2674 ---------------------------
2675 -- Check_Object_Renaming --
2676 ---------------------------
2678 function Check_Object_Renaming (N : Node_Id) return Traverse_Result is
2679 begin
2680 case Nkind (Original_Node (N)) is
2681 when N_Expanded_Name
2682 | N_Identifier
2684 declare
2685 Obj_Id : constant Entity_Id := Entity (Original_Node (N));
2686 begin
2687 -- Recognize the case when SPARK expansion rewrites a
2688 -- reference to an object renaming.
2690 if Present (Obj_Id)
2691 and then Is_Object (Obj_Id)
2692 and then Present (Renamed_Object (Obj_Id))
2693 and then Nkind (Renamed_Object (Obj_Id)) not in N_Entity
2695 -- Copy_Generic_Node called for inlining expects the
2696 -- references to global entities to have the same kind
2697 -- in the "generic" code and its "instantiation".
2699 and then Nkind (Original_Node (N)) /=
2700 Nkind (Renamed_Object (Obj_Id))
2701 then
2702 return Abandon;
2703 else
2704 return OK;
2705 end if;
2706 end;
2708 when others =>
2709 return OK;
2710 end case;
2711 end Check_Object_Renaming;
2713 function Check_All_Object_Renamings is new
2714 Traverse_Func (Check_Object_Renaming);
2716 -- Start of processing for Check_Object_Renaming_In_GNATprove_Mode
2718 begin
2719 -- Subprograms with object renamings replaced by the special SPARK
2720 -- expansion cannot be inlined.
2722 if Check_All_Object_Renamings (Body_Decl) /= OK then
2723 Cannot_Inline ("cannot inline & (object renaming)?",
2724 Body_Decl, Spec_Id);
2725 Set_Body_To_Inline (Decl, Empty);
2726 end if;
2727 end Check_Object_Renaming_In_GNATprove_Mode;
2729 -------------------------------------
2730 -- Check_Package_Body_For_Inlining --
2731 -------------------------------------
2733 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2734 Bname : Unit_Name_Type;
2735 E : Entity_Id;
2736 OK : Boolean;
2738 begin
2739 -- Legacy implementation (relying on frontend inlining)
2741 if not Back_End_Inlining
2742 and then Is_Compilation_Unit (P)
2743 and then not Is_Generic_Instance (P)
2744 then
2745 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2747 E := First_Entity (P);
2748 while Present (E) loop
2749 if Has_Pragma_Inline_Always (E)
2750 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2751 then
2752 if not Is_Loaded (Bname) then
2753 Load_Needed_Body (N, OK);
2755 if OK then
2757 -- Check we are not trying to inline a parent whose body
2758 -- depends on a child, when we are compiling the body of
2759 -- the child. Otherwise we have a potential elaboration
2760 -- circularity with inlined subprograms and with
2761 -- Taft-Amendment types.
2763 declare
2764 Comp : Node_Id; -- Body just compiled
2765 Child_Spec : Entity_Id; -- Spec of main unit
2766 Ent : Entity_Id; -- For iteration
2767 With_Clause : Node_Id; -- Context of body.
2769 begin
2770 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2771 and then Present (Body_Entity (P))
2772 then
2773 Child_Spec :=
2774 Defining_Entity
2775 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2777 Comp :=
2778 Parent (Unit_Declaration_Node (Body_Entity (P)));
2780 -- Check whether the context of the body just
2781 -- compiled includes a child of itself, and that
2782 -- child is the spec of the main compilation.
2784 With_Clause := First (Context_Items (Comp));
2785 while Present (With_Clause) loop
2786 if Nkind (With_Clause) = N_With_Clause
2787 and then
2788 Scope (Entity (Name (With_Clause))) = P
2789 and then
2790 Entity (Name (With_Clause)) = Child_Spec
2791 then
2792 Error_Msg_Node_2 := Child_Spec;
2793 Error_Msg_NE
2794 ("body of & depends on child unit&??",
2795 With_Clause, P);
2796 Error_Msg_N
2797 ("\subprograms in body cannot be inlined??",
2798 With_Clause);
2800 -- Disable further inlining from this unit,
2801 -- and keep Taft-amendment types incomplete.
2803 Ent := First_Entity (P);
2804 while Present (Ent) loop
2805 if Is_Type (Ent)
2806 and then Has_Completion_In_Body (Ent)
2807 then
2808 Set_Full_View (Ent, Empty);
2810 elsif Is_Subprogram (Ent) then
2811 Set_Is_Inlined (Ent, False);
2812 end if;
2814 Next_Entity (Ent);
2815 end loop;
2817 return;
2818 end if;
2820 Next (With_Clause);
2821 end loop;
2822 end if;
2823 end;
2825 elsif Ineffective_Inline_Warnings then
2826 Error_Msg_Unit_1 := Bname;
2827 Error_Msg_N
2828 ("unable to inline subprograms defined in $?p?", P);
2829 Error_Msg_N ("\body not found?p?", P);
2830 return;
2831 end if;
2832 end if;
2834 return;
2835 end if;
2837 Next_Entity (E);
2838 end loop;
2839 end if;
2840 end Check_Package_Body_For_Inlining;
2842 --------------------
2843 -- Cleanup_Scopes --
2844 --------------------
2846 procedure Cleanup_Scopes is
2847 Decl : Node_Id;
2848 Elmt : Elmt_Id;
2849 Fin : Entity_Id;
2850 Kind : Entity_Kind;
2851 Scop : Entity_Id;
2853 begin
2854 Elmt := First_Elmt (To_Clean);
2855 while Present (Elmt) loop
2856 Scop := Node (Elmt);
2857 Kind := Ekind (Scop);
2859 if Kind = E_Block then
2860 Decl := Parent (Block_Node (Scop));
2862 else
2863 Decl := Unit_Declaration_Node (Scop);
2865 if Nkind (Decl) in N_Subprogram_Declaration
2866 | N_Task_Type_Declaration
2867 | N_Subprogram_Body_Stub
2868 then
2869 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2870 end if;
2871 end if;
2873 -- Finalizers are built only for package specs and bodies that are
2874 -- compilation units, so check that we do not have anything else.
2875 -- Moreover, they must be built at most once for each entity during
2876 -- the compilation of the main unit. However, if other units are
2877 -- later compiled for inlining purposes, they may also contain body
2878 -- instances and, therefore, appear again here, so we need to make
2879 -- sure that we do not build two finalizers for them (note that the
2880 -- contents of the finalizer for these units is irrelevant since it
2881 -- is not output in the generated code).
2883 if Kind in E_Package | E_Package_Body then
2884 declare
2885 Unit_Entity : constant Entity_Id :=
2886 (if Kind = E_Package then Scop else Spec_Entity (Scop));
2888 begin
2889 pragma Assert (Is_Compilation_Unit (Unit_Entity)
2890 and then (No (Finalizer (Scop))
2891 or else Unit_Entity /= Main_Unit_Entity));
2893 if No (Finalizer (Scop)) then
2894 Build_Finalizer
2895 (N => Decl,
2896 Clean_Stmts => No_List,
2897 Mark_Id => Empty,
2898 Top_Decls => No_List,
2899 Defer_Abort => False,
2900 Fin_Id => Fin);
2902 if Present (Fin) then
2903 Set_Finalizer (Scop, Fin);
2904 end if;
2905 end if;
2906 end;
2908 else
2909 Push_Scope (Scop);
2910 Expand_Cleanup_Actions (Decl);
2911 End_Scope;
2912 end if;
2914 Next_Elmt (Elmt);
2915 end loop;
2916 end Cleanup_Scopes;
2918 -----------------------------------------------
2919 -- Establish_Actual_Mapping_For_Inlined_Call --
2920 -----------------------------------------------
2922 procedure Establish_Actual_Mapping_For_Inlined_Call
2923 (N : Node_Id;
2924 Subp : Entity_Id;
2925 Decls : List_Id;
2926 Body_Or_Expr_To_Check : Node_Id)
2929 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2930 -- Determine whether a formal parameter is used only once in
2931 -- Body_Or_Expr_To_Check.
2933 -------------------------
2934 -- Formal_Is_Used_Once --
2935 -------------------------
2937 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2938 Use_Counter : Nat := 0;
2940 function Count_Uses (N : Node_Id) return Traverse_Result;
2941 -- Traverse the tree and count the uses of the formal parameter.
2942 -- In this case, for optimization purposes, we do not need to
2943 -- continue the traversal once more than one use is encountered.
2945 ----------------
2946 -- Count_Uses --
2947 ----------------
2949 function Count_Uses (N : Node_Id) return Traverse_Result is
2950 begin
2951 -- The original node is an identifier
2953 if Nkind (N) = N_Identifier
2954 and then Present (Entity (N))
2956 -- Original node's entity points to the one in the copied body
2958 and then Nkind (Entity (N)) = N_Identifier
2959 and then Present (Entity (Entity (N)))
2961 -- The entity of the copied node is the formal parameter
2963 and then Entity (Entity (N)) = Formal
2964 then
2965 Use_Counter := Use_Counter + 1;
2967 -- If this is a second use then abandon the traversal
2969 if Use_Counter > 1 then
2970 return Abandon;
2971 end if;
2972 end if;
2974 return OK;
2975 end Count_Uses;
2977 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2979 -- Start of processing for Formal_Is_Used_Once
2981 begin
2982 Count_Formal_Uses (Body_Or_Expr_To_Check);
2983 return Use_Counter = 1;
2984 end Formal_Is_Used_Once;
2986 -- Local Data --
2988 F : Entity_Id;
2989 A : Node_Id;
2990 Decl : Node_Id;
2991 Loc : constant Source_Ptr := Sloc (N);
2992 New_A : Node_Id;
2993 Temp : Entity_Id;
2994 Temp_Typ : Entity_Id;
2996 -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
2998 begin
2999 F := First_Formal (Subp);
3000 A := First_Actual (N);
3001 while Present (F) loop
3002 if Present (Renamed_Object (F)) then
3004 -- If expander is active, it is an error to try to inline a
3005 -- recursive subprogram. In GNATprove mode, just indicate that the
3006 -- inlining will not happen, and mark the subprogram as not always
3007 -- inlined.
3009 if GNATprove_Mode then
3010 Cannot_Inline
3011 ("cannot inline call to recursive subprogram?", N, Subp);
3012 Set_Is_Inlined_Always (Subp, False);
3013 else
3014 Error_Msg_N
3015 ("cannot inline call to recursive subprogram", N);
3016 end if;
3018 return;
3019 end if;
3021 -- Reset Last_Assignment for any parameters of mode out or in out, to
3022 -- prevent spurious warnings about overwriting for assignments to the
3023 -- formal in the inlined code.
3025 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3027 -- In GNATprove mode a protected component acting as an actual
3028 -- subprogram parameter will appear as inlined-for-proof. However,
3029 -- its E_Component entity is not an assignable object, so the
3030 -- assertion in Set_Last_Assignment will fail. We just omit the
3031 -- call to Set_Last_Assignment, because GNATprove flags useless
3032 -- assignments with its own flow analysis.
3034 -- In GNAT mode such a problem does not occur, because protected
3035 -- components are inlined via object renamings whose entity kind
3036 -- E_Variable is assignable.
3038 if Is_Assignable (Entity (A)) then
3039 Set_Last_Assignment (Entity (A), Empty);
3040 else
3041 pragma Assert
3042 (GNATprove_Mode and then Is_Protected_Component (Entity (A)));
3043 end if;
3044 end if;
3046 -- If the argument may be a controlling argument in a call within
3047 -- the inlined body, we must preserve its class-wide nature to ensure
3048 -- that dynamic dispatching will take place subsequently. If the
3049 -- formal has a constraint, then it must be preserved to retain the
3050 -- semantics of the body.
3052 if Is_Class_Wide_Type (Etype (F))
3053 or else (Is_Access_Type (Etype (F))
3054 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3055 then
3056 Temp_Typ := Etype (F);
3058 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3059 and then Etype (F) /= Base_Type (Etype (F))
3060 and then Is_Constrained (Etype (F))
3061 then
3062 Temp_Typ := Etype (F);
3064 else
3065 Temp_Typ := Etype (A);
3066 end if;
3068 -- If the actual is a simple name or a literal, no need to create a
3069 -- temporary, object can be used directly. Skip this optimization in
3070 -- GNATprove mode, to make sure any check on a type conversion will
3071 -- be issued.
3073 if (Is_Entity_Name (A)
3074 and then
3075 (not Is_Scalar_Type (Etype (A))
3076 or else Ekind (Entity (A)) = E_Enumeration_Literal)
3077 and then not GNATprove_Mode)
3079 -- When the actual is an identifier and the corresponding formal is
3080 -- used only once in the original body, the formal can be substituted
3081 -- directly with the actual parameter. Skip this optimization in
3082 -- GNATprove mode, to make sure any check on a type conversion
3083 -- will be issued.
3085 or else
3086 (Nkind (A) = N_Identifier
3087 and then Formal_Is_Used_Once (F)
3088 and then not GNATprove_Mode)
3090 -- If the actual is a literal and the formal has its address taken,
3091 -- we cannot pass the literal itself as an argument, so its value
3092 -- must be captured in a temporary.
3094 or else
3095 (Nkind (A) in
3096 N_Real_Literal | N_Integer_Literal | N_Character_Literal
3097 and then not Address_Taken (F))
3098 then
3099 if Etype (F) /= Etype (A) then
3100 Set_Renamed_Object
3101 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3102 else
3103 Set_Renamed_Object (F, A);
3104 end if;
3106 else
3107 Temp := Make_Temporary (Loc, 'C');
3109 -- If the actual for an in/in-out parameter is a view conversion,
3110 -- make it into an unchecked conversion, given that an untagged
3111 -- type conversion is not a proper object for a renaming.
3113 -- In-out conversions that involve real conversions have already
3114 -- been transformed in Expand_Actuals.
3116 if Nkind (A) = N_Type_Conversion
3117 and then Ekind (F) /= E_In_Parameter
3118 then
3119 New_A := Unchecked_Convert_To (Etype (F), Expression (A));
3121 -- In GNATprove mode, keep the most precise type of the actual for
3122 -- the temporary variable, when the formal type is unconstrained.
3123 -- Otherwise, the AST may contain unexpected assignment statements
3124 -- to a temporary variable of unconstrained type renaming a local
3125 -- variable of constrained type, which is not expected by
3126 -- GNATprove.
3128 elsif Etype (F) /= Etype (A)
3129 and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
3130 then
3131 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3132 Temp_Typ := Etype (F);
3134 else
3135 New_A := Relocate_Node (A);
3136 end if;
3138 Set_Sloc (New_A, Sloc (N));
3140 -- If the actual has a by-reference type, it cannot be copied,
3141 -- so its value is captured in a renaming declaration. Otherwise
3142 -- declare a local constant initialized with the actual.
3144 -- We also use a renaming declaration for expressions of an array
3145 -- type that is not bit-packed, both for efficiency reasons and to
3146 -- respect the semantics of the call: in most cases the original
3147 -- call will pass the parameter by reference, and thus the inlined
3148 -- code will have the same semantics.
3150 -- Finally, we need a renaming declaration in the case of limited
3151 -- types for which initialization cannot be by copy either.
3153 if Ekind (F) = E_In_Parameter
3154 and then not Is_By_Reference_Type (Etype (A))
3155 and then not Is_Limited_Type (Etype (A))
3156 and then
3157 (not Is_Array_Type (Etype (A))
3158 or else not Is_Object_Reference (A)
3159 or else Is_Bit_Packed_Array (Etype (A)))
3160 then
3161 Decl :=
3162 Make_Object_Declaration (Loc,
3163 Defining_Identifier => Temp,
3164 Constant_Present => True,
3165 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3166 Expression => New_A);
3168 else
3169 -- In GNATprove mode, make an explicit copy of input
3170 -- parameters when formal and actual types differ, to make
3171 -- sure any check on the type conversion will be issued.
3172 -- The legality of the copy is ensured by calling first
3173 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3175 if GNATprove_Mode
3176 and then Ekind (F) /= E_Out_Parameter
3177 and then not Same_Type (Etype (F), Etype (A))
3178 then
3179 pragma Assert (not Is_By_Reference_Type (Etype (A)));
3180 pragma Assert (not Is_Limited_Type (Etype (A)));
3182 Append_To (Decls,
3183 Make_Object_Declaration (Loc,
3184 Defining_Identifier => Make_Temporary (Loc, 'C'),
3185 Constant_Present => True,
3186 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3187 Expression => New_Copy_Tree (New_A)));
3188 end if;
3190 Decl :=
3191 Make_Object_Renaming_Declaration (Loc,
3192 Defining_Identifier => Temp,
3193 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3194 Name => New_A);
3195 end if;
3197 Append (Decl, Decls);
3198 Set_Renamed_Object (F, Temp);
3199 end if;
3201 Next_Formal (F);
3202 Next_Actual (A);
3203 end loop;
3204 end Establish_Actual_Mapping_For_Inlined_Call;
3206 -------------------------
3207 -- Expand_Inlined_Call --
3208 -------------------------
3210 procedure Expand_Inlined_Call
3211 (N : Node_Id;
3212 Subp : Entity_Id;
3213 Orig_Subp : Entity_Id)
3215 Decls : constant List_Id := New_List;
3216 Is_Predef : constant Boolean :=
3217 Is_Predefined_Unit (Get_Source_Unit (Subp));
3218 Loc : constant Source_Ptr := Sloc (N);
3219 Orig_Bod : constant Node_Id :=
3220 Body_To_Inline (Unit_Declaration_Node (Subp));
3222 Uses_Back_End : constant Boolean :=
3223 Back_End_Inlining and then Optimization_Level > 0;
3224 -- The back-end expansion is used if the target supports back-end
3225 -- inlining and some level of optimixation is required; otherwise
3226 -- the inlining takes place fully as a tree expansion.
3228 Blk : Node_Id;
3229 Decl : Node_Id;
3230 Exit_Lab : Entity_Id := Empty;
3231 Lab_Decl : Node_Id := Empty;
3232 Lab_Id : Node_Id;
3233 Num_Ret : Nat := 0;
3234 Ret_Type : Entity_Id;
3235 Temp : Entity_Id;
3237 Is_Unc : Boolean;
3238 Is_Unc_Decl : Boolean;
3239 -- If the type returned by the function is unconstrained and the call
3240 -- can be inlined, special processing is required.
3242 Return_Object : Entity_Id := Empty;
3243 -- Entity in declaration in an extended_return_statement
3245 Targ : Node_Id := Empty;
3246 -- The target of the call. If context is an assignment statement then
3247 -- this is the left-hand side of the assignment, else it is a temporary
3248 -- to which the return value is assigned prior to rewriting the call.
3250 Targ1 : Node_Id := Empty;
3251 -- A separate target used when the return type is unconstrained
3253 procedure Declare_Postconditions_Result;
3254 -- When generating C code, declare _Result, which may be used in the
3255 -- inlined _Postconditions procedure to verify the return value.
3257 procedure Make_Exit_Label;
3258 -- Build declaration for exit label to be used in Return statements,
3259 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
3260 -- declaration). Does nothing if Exit_Lab already set.
3262 procedure Make_Loop_Labels_Unique (HSS : Node_Id);
3263 -- When compiling for CCG and performing front-end inlining, replace
3264 -- loop names and references to them so that they do not conflict with
3265 -- homographs in the current subprogram.
3267 function Process_Formals (N : Node_Id) return Traverse_Result;
3268 -- Replace occurrence of a formal with the corresponding actual, or the
3269 -- thunk generated for it. Replace a return statement with an assignment
3270 -- to the target of the call, with appropriate conversions if needed.
3272 function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
3273 -- Because aspects are linked indirectly to the rest of the tree,
3274 -- replacement of formals appearing in aspect specifications must
3275 -- be performed in a separate pass, using an instantiation of the
3276 -- previous subprogram over aspect specifications reachable from N.
3278 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
3279 -- If the call being expanded is that of an internal subprogram, set the
3280 -- sloc of the generated block to that of the call itself, so that the
3281 -- expansion is skipped by the "next" command in gdb. Same processing
3282 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
3283 -- Debug_Generated_Code is true, suppress this change to simplify our
3284 -- own development. Same in GNATprove mode, to ensure that warnings and
3285 -- diagnostics point to the proper location.
3287 procedure Reset_Dispatching_Calls (N : Node_Id);
3288 -- In subtree N search for occurrences of dispatching calls that use the
3289 -- Ada 2005 Object.Operation notation and the object is a formal of the
3290 -- inlined subprogram. Reset the entity associated with Operation in all
3291 -- the found occurrences.
3293 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
3294 -- If the function body is a single expression, replace call with
3295 -- expression, else insert block appropriately.
3297 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
3298 -- If procedure body has no local variables, inline body without
3299 -- creating block, otherwise rewrite call with block.
3301 -----------------------------------
3302 -- Declare_Postconditions_Result --
3303 -----------------------------------
3305 procedure Declare_Postconditions_Result is
3306 Enclosing_Subp : constant Entity_Id := Scope (Subp);
3308 begin
3309 pragma Assert
3310 (Modify_Tree_For_C
3311 and then Is_Subprogram (Enclosing_Subp)
3312 and then Present (Wrapped_Statements (Enclosing_Subp)));
3314 if Ekind (Enclosing_Subp) = E_Function then
3315 if Nkind (First (Parameter_Associations (N))) in
3316 N_Numeric_Or_String_Literal
3317 then
3318 Append_To (Declarations (Blk),
3319 Make_Object_Declaration (Loc,
3320 Defining_Identifier =>
3321 Make_Defining_Identifier (Loc, Name_uResult),
3322 Constant_Present => True,
3323 Object_Definition =>
3324 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
3325 Expression =>
3326 New_Copy_Tree (First (Parameter_Associations (N)))));
3327 else
3328 Append_To (Declarations (Blk),
3329 Make_Object_Renaming_Declaration (Loc,
3330 Defining_Identifier =>
3331 Make_Defining_Identifier (Loc, Name_uResult),
3332 Subtype_Mark =>
3333 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
3334 Name =>
3335 New_Copy_Tree (First (Parameter_Associations (N)))));
3336 end if;
3337 end if;
3338 end Declare_Postconditions_Result;
3340 ---------------------
3341 -- Make_Exit_Label --
3342 ---------------------
3344 procedure Make_Exit_Label is
3345 Lab_Ent : Entity_Id;
3346 begin
3347 if No (Exit_Lab) then
3348 Lab_Ent := Make_Temporary (Loc, 'L');
3349 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
3350 Exit_Lab := Make_Label (Loc, Lab_Id);
3351 Lab_Decl :=
3352 Make_Implicit_Label_Declaration (Loc,
3353 Defining_Identifier => Lab_Ent,
3354 Label_Construct => Exit_Lab);
3355 end if;
3356 end Make_Exit_Label;
3358 -----------------------------
3359 -- Make_Loop_Labels_Unique --
3360 -----------------------------
3362 procedure Make_Loop_Labels_Unique (HSS : Node_Id) is
3363 function Process_Loop (N : Node_Id) return Traverse_Result;
3365 ------------------
3366 -- Process_Loop --
3367 ------------------
3369 function Process_Loop (N : Node_Id) return Traverse_Result is
3370 Id : Entity_Id;
3372 begin
3373 if Nkind (N) = N_Loop_Statement
3374 and then Present (Identifier (N))
3375 then
3376 -- Create new external name for loop and update the
3377 -- corresponding entity.
3379 Id := Entity (Identifier (N));
3380 Set_Chars (Id, New_External_Name (Chars (Id), 'L', -1));
3381 Set_Chars (Identifier (N), Chars (Id));
3383 elsif Nkind (N) = N_Exit_Statement
3384 and then Present (Name (N))
3385 then
3386 -- The exit statement must name an enclosing loop, whose name
3387 -- has already been updated.
3389 Set_Chars (Name (N), Chars (Entity (Name (N))));
3390 end if;
3392 return OK;
3393 end Process_Loop;
3395 procedure Update_Loop_Names is new Traverse_Proc (Process_Loop);
3397 -- Local variables
3399 Stmt : Node_Id;
3401 -- Start of processing for Make_Loop_Labels_Unique
3403 begin
3404 if Modify_Tree_For_C then
3405 Stmt := First (Statements (HSS));
3406 while Present (Stmt) loop
3407 Update_Loop_Names (Stmt);
3408 Next (Stmt);
3409 end loop;
3410 end if;
3411 end Make_Loop_Labels_Unique;
3413 ---------------------
3414 -- Process_Formals --
3415 ---------------------
3417 function Process_Formals (N : Node_Id) return Traverse_Result is
3418 A : Entity_Id;
3419 E : Entity_Id;
3420 Ret : Node_Id;
3422 Had_Private_View : Boolean;
3424 begin
3425 if Is_Entity_Name (N) and then Present (Entity (N)) then
3426 E := Entity (N);
3428 if Is_Formal (E) and then Scope (E) = Subp then
3429 A := Renamed_Object (E);
3431 -- Rewrite the occurrence of the formal into an occurrence of
3432 -- the actual. Also establish visibility on the proper view of
3433 -- the actual's subtype for the body's context (if the actual's
3434 -- subtype is private at the call point but its full view is
3435 -- visible to the body, then the inlined tree here must be
3436 -- analyzed with the full view).
3438 -- The Has_Private_View flag is cleared by rewriting, so it
3439 -- must be explicitly saved and restored, just like when
3440 -- instantiating the body to inline.
3442 if Is_Entity_Name (A) then
3443 Had_Private_View := Has_Private_View (N);
3444 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
3445 Set_Has_Private_View (N, Had_Private_View);
3446 Check_Private_View (N);
3448 elsif Nkind (A) = N_Defining_Identifier then
3449 Had_Private_View := Has_Private_View (N);
3450 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
3451 Set_Has_Private_View (N, Had_Private_View);
3452 Check_Private_View (N);
3454 -- Numeric literal
3456 else
3457 Rewrite (N, New_Copy (A));
3458 end if;
3459 end if;
3461 return Skip;
3463 elsif Is_Entity_Name (N)
3464 and then Present (Return_Object)
3465 and then Chars (N) = Chars (Return_Object)
3466 then
3467 -- Occurrence within an extended return statement. The return
3468 -- object is local to the body been inlined, and thus the generic
3469 -- copy is not analyzed yet, so we match by name, and replace it
3470 -- with target of call.
3472 if Nkind (Targ) = N_Defining_Identifier then
3473 Rewrite (N, New_Occurrence_Of (Targ, Loc));
3474 else
3475 Rewrite (N, New_Copy_Tree (Targ));
3476 end if;
3478 return Skip;
3480 elsif Nkind (N) = N_Simple_Return_Statement then
3481 if No (Expression (N)) then
3482 Num_Ret := Num_Ret + 1;
3483 Make_Exit_Label;
3484 Rewrite (N,
3485 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
3487 else
3488 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
3489 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
3490 then
3491 -- Function body is a single expression. No need for
3492 -- exit label.
3494 null;
3496 else
3497 Num_Ret := Num_Ret + 1;
3498 Make_Exit_Label;
3499 end if;
3501 -- Because of the presence of private types, the views of the
3502 -- expression and the context may be different, so place
3503 -- a type conversion to the context type to avoid spurious
3504 -- errors, e.g. when the expression is a numeric literal and
3505 -- the context is private. If the expression is an aggregate,
3506 -- use a qualified expression, because an aggregate is not a
3507 -- legal argument of a conversion. Ditto for numeric, character
3508 -- and string literals, and attributes that yield a universal
3509 -- type, because those must be resolved to a specific type.
3511 if Nkind (Expression (N)) in N_Aggregate
3512 | N_Character_Literal
3513 | N_Null
3514 | N_String_Literal
3515 or else Yields_Universal_Type (Expression (N))
3516 then
3517 Ret :=
3518 Make_Qualified_Expression (Sloc (N),
3519 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
3520 Expression => Relocate_Node (Expression (N)));
3522 -- Use an unchecked type conversion between access types, for
3523 -- which a type conversion would not always be valid, as no
3524 -- check may result from the conversion.
3526 elsif Is_Access_Type (Ret_Type) then
3527 Ret :=
3528 Unchecked_Convert_To
3529 (Ret_Type, Relocate_Node (Expression (N)));
3531 -- Otherwise use a type conversion, which may trigger a check
3533 else
3534 Ret :=
3535 Make_Type_Conversion (Sloc (N),
3536 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
3537 Expression => Relocate_Node (Expression (N)));
3538 end if;
3540 if Nkind (Targ) = N_Defining_Identifier then
3541 Rewrite (N,
3542 Make_Assignment_Statement (Loc,
3543 Name => New_Occurrence_Of (Targ, Loc),
3544 Expression => Ret));
3545 else
3546 Rewrite (N,
3547 Make_Assignment_Statement (Loc,
3548 Name => New_Copy (Targ),
3549 Expression => Ret));
3550 end if;
3552 Set_Assignment_OK (Name (N));
3554 if Present (Exit_Lab) then
3555 Insert_After (N,
3556 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
3557 end if;
3558 end if;
3560 return OK;
3562 -- An extended return becomes a block whose first statement is the
3563 -- assignment of the initial expression of the return object to the
3564 -- target of the call itself.
3566 elsif Nkind (N) = N_Extended_Return_Statement then
3567 declare
3568 Return_Decl : constant Entity_Id :=
3569 First (Return_Object_Declarations (N));
3570 Assign : Node_Id;
3572 begin
3573 Return_Object := Defining_Identifier (Return_Decl);
3575 if Present (Expression (Return_Decl)) then
3576 if Nkind (Targ) = N_Defining_Identifier then
3577 Assign :=
3578 Make_Assignment_Statement (Loc,
3579 Name => New_Occurrence_Of (Targ, Loc),
3580 Expression => Expression (Return_Decl));
3581 else
3582 Assign :=
3583 Make_Assignment_Statement (Loc,
3584 Name => New_Copy (Targ),
3585 Expression => Expression (Return_Decl));
3586 end if;
3588 Set_Assignment_OK (Name (Assign));
3590 if No (Handled_Statement_Sequence (N)) then
3591 Set_Handled_Statement_Sequence (N,
3592 Make_Handled_Sequence_Of_Statements (Loc,
3593 Statements => New_List));
3594 end if;
3596 Prepend (Assign,
3597 Statements (Handled_Statement_Sequence (N)));
3598 end if;
3600 Rewrite (N,
3601 Make_Block_Statement (Loc,
3602 Handled_Statement_Sequence =>
3603 Handled_Statement_Sequence (N)));
3605 return OK;
3606 end;
3608 -- Remove pragma Unreferenced since it may refer to formals that
3609 -- are not visible in the inlined body, and in any case we will
3610 -- not be posting warnings on the inlined body so it is unneeded.
3612 elsif Nkind (N) = N_Pragma
3613 and then Pragma_Name (N) = Name_Unreferenced
3614 then
3615 Rewrite (N, Make_Null_Statement (Sloc (N)));
3616 return OK;
3618 else
3619 return OK;
3620 end if;
3621 end Process_Formals;
3623 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
3625 --------------------------------
3626 -- Process_Formals_In_Aspects --
3627 --------------------------------
3629 function Process_Formals_In_Aspects
3630 (N : Node_Id) return Traverse_Result
3632 begin
3633 if Nkind (N) = N_Aspect_Specification then
3634 Replace_Formals (Expression (N));
3635 end if;
3636 return OK;
3637 end Process_Formals_In_Aspects;
3639 procedure Replace_Formals_In_Aspects is
3640 new Traverse_Proc (Process_Formals_In_Aspects);
3642 ------------------
3643 -- Process_Sloc --
3644 ------------------
3646 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
3647 begin
3648 if not Debug_Generated_Code then
3649 Set_Sloc (Nod, Sloc (N));
3650 Set_Comes_From_Source (Nod, False);
3651 end if;
3653 return OK;
3654 end Process_Sloc;
3656 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
3658 ------------------------------
3659 -- Reset_Dispatching_Calls --
3660 ------------------------------
3662 procedure Reset_Dispatching_Calls (N : Node_Id) is
3664 function Do_Reset (N : Node_Id) return Traverse_Result;
3666 --------------
3667 -- Do_Reset --
3668 --------------
3670 function Do_Reset (N : Node_Id) return Traverse_Result is
3671 begin
3672 if Nkind (N) = N_Procedure_Call_Statement
3673 and then Nkind (Name (N)) = N_Selected_Component
3674 and then Nkind (Prefix (Name (N))) = N_Identifier
3675 and then Is_Formal (Entity (Prefix (Name (N))))
3676 and then Is_Dispatching_Operation
3677 (Entity (Selector_Name (Name (N))))
3678 then
3679 Set_Entity (Selector_Name (Name (N)), Empty);
3680 end if;
3682 return OK;
3683 end Do_Reset;
3685 procedure Do_Reset_Calls is new Traverse_Proc (Do_Reset);
3687 begin
3688 Do_Reset_Calls (N);
3689 end Reset_Dispatching_Calls;
3691 ---------------------------
3692 -- Rewrite_Function_Call --
3693 ---------------------------
3695 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
3696 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3697 Fst : constant Node_Id := First (Statements (HSS));
3699 begin
3700 Make_Loop_Labels_Unique (HSS);
3702 -- Optimize simple case: function body is a single return statement,
3703 -- which has been expanded into an assignment.
3705 if Is_Empty_List (Declarations (Blk))
3706 and then Nkind (Fst) = N_Assignment_Statement
3707 and then No (Next (Fst))
3708 then
3709 -- The function call may have been rewritten as the temporary
3710 -- that holds the result of the call, in which case remove the
3711 -- now useless declaration.
3713 if Nkind (N) = N_Identifier
3714 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3715 then
3716 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
3717 end if;
3719 Rewrite (N, Expression (Fst));
3721 elsif Nkind (N) = N_Identifier
3722 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3723 then
3724 -- The block assigns the result of the call to the temporary
3726 Insert_After (Parent (Entity (N)), Blk);
3728 -- If the context is an assignment, and the left-hand side is free of
3729 -- side-effects, the replacement is also safe.
3731 elsif Nkind (Parent (N)) = N_Assignment_Statement
3732 and then
3733 (Is_Entity_Name (Name (Parent (N)))
3734 or else
3735 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
3736 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
3738 or else
3739 (Nkind (Name (Parent (N))) = N_Selected_Component
3740 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
3741 then
3742 -- Replace assignment with the block
3744 declare
3745 Original_Assignment : constant Node_Id := Parent (N);
3747 begin
3748 -- Preserve the original assignment node to keep the complete
3749 -- assignment subtree consistent enough for Analyze_Assignment
3750 -- to proceed (specifically, the original Lhs node must still
3751 -- have an assignment statement as its parent).
3753 -- We cannot rely on Original_Node to go back from the block
3754 -- node to the assignment node, because the assignment might
3755 -- already be a rewrite substitution.
3757 Discard_Node (Relocate_Node (Original_Assignment));
3758 Rewrite (Original_Assignment, Blk);
3759 end;
3761 elsif Nkind (Parent (N)) = N_Object_Declaration then
3763 -- A call to a function which returns an unconstrained type
3764 -- found in the expression initializing an object-declaration is
3765 -- expanded into a procedure call which must be added after the
3766 -- object declaration.
3768 if Is_Unc_Decl and Back_End_Inlining then
3769 Insert_Action_After (Parent (N), Blk);
3770 else
3771 Set_Expression (Parent (N), Empty);
3772 Insert_After (Parent (N), Blk);
3773 end if;
3775 elsif Is_Unc and then not Back_End_Inlining then
3776 Insert_Before (Parent (N), Blk);
3777 end if;
3778 end Rewrite_Function_Call;
3780 ----------------------------
3781 -- Rewrite_Procedure_Call --
3782 ----------------------------
3784 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
3785 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3787 begin
3788 Make_Loop_Labels_Unique (HSS);
3790 -- If there is a transient scope for N, this will be the scope of the
3791 -- actions for N, and the statements in Blk need to be within this
3792 -- scope. For example, they need to have visibility on the constant
3793 -- declarations created for the formals.
3795 -- If N needs no transient scope, and if there are no declarations in
3796 -- the inlined body, we can do a little optimization and insert the
3797 -- statements for the body directly after N, and rewrite N to a
3798 -- null statement, instead of rewriting N into a full-blown block
3799 -- statement.
3801 if not Scope_Is_Transient
3802 and then Is_Empty_List (Declarations (Blk))
3803 then
3804 Insert_List_After (N, Statements (HSS));
3805 Rewrite (N, Make_Null_Statement (Loc));
3806 else
3807 Rewrite (N, Blk);
3808 end if;
3809 end Rewrite_Procedure_Call;
3811 -- Start of processing for Expand_Inlined_Call
3813 begin
3814 -- Initializations for old/new semantics
3816 if not Uses_Back_End then
3817 Is_Unc := Is_Array_Type (Etype (Subp))
3818 and then not Is_Constrained (Etype (Subp));
3819 Is_Unc_Decl := False;
3820 else
3821 Is_Unc := Returns_Unconstrained_Type (Subp)
3822 and then Optimization_Level > 0;
3823 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
3824 and then Is_Unc;
3825 end if;
3827 -- Check for an illegal attempt to inline a recursive procedure. If the
3828 -- subprogram has parameters this is detected when trying to supply a
3829 -- binding for parameters that already have one. For parameterless
3830 -- subprograms this must be done explicitly.
3832 if In_Open_Scopes (Subp) then
3833 Cannot_Inline
3834 ("cannot inline call to recursive subprogram?", N, Subp);
3835 Set_Is_Inlined (Subp, False);
3836 return;
3838 -- Skip inlining if this is not a true inlining since the attribute
3839 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3840 -- true inlining, Orig_Bod has code rather than being an entity.
3842 elsif Nkind (Orig_Bod) in N_Entity then
3843 return;
3844 end if;
3846 if Nkind (Orig_Bod) in N_Defining_Identifier
3847 | N_Defining_Operator_Symbol
3848 then
3849 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3850 -- can be replaced with calls to the renamed entity directly, because
3851 -- the subprograms are subtype conformant. If the renamed subprogram
3852 -- is an inherited operation, we must redo the expansion because
3853 -- implicit conversions may be needed. Similarly, if the renamed
3854 -- entity is inlined, expand the call for further optimizations.
3856 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3858 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
3859 Expand_Call (N);
3860 end if;
3862 return;
3863 end if;
3865 -- Register the call in the list of inlined calls
3867 Append_New_Elmt (N, To => Inlined_Calls);
3869 -- Use generic machinery to copy body of inlined subprogram, as if it
3870 -- were an instantiation, resetting source locations appropriately, so
3871 -- that nested inlined calls appear in the main unit.
3873 Save_Env (Subp, Empty);
3874 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3876 -- Old semantics
3878 if not Uses_Back_End then
3879 declare
3880 Bod : Node_Id;
3882 begin
3883 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3884 Blk :=
3885 Make_Block_Statement (Loc,
3886 Declarations => Declarations (Bod),
3887 Handled_Statement_Sequence =>
3888 Handled_Statement_Sequence (Bod));
3890 if No (Declarations (Bod)) then
3891 Set_Declarations (Blk, New_List);
3892 end if;
3894 -- When generating C code, declare _Result, which may be used to
3895 -- verify the return value.
3897 if Modify_Tree_For_C
3898 and then Nkind (N) = N_Procedure_Call_Statement
3899 and then Chars (Name (N)) = Name_uWrapped_Statements
3900 then
3901 Declare_Postconditions_Result;
3902 end if;
3904 -- For the unconstrained case, capture the name of the local
3905 -- variable that holds the result. This must be the first
3906 -- declaration in the block, because its bounds cannot depend
3907 -- on local variables. Otherwise there is no way to declare the
3908 -- result outside of the block. Needless to say, in general the
3909 -- bounds will depend on the actuals in the call.
3911 -- If the context is an assignment statement, as is the case
3912 -- for the expansion of an extended return, the left-hand side
3913 -- provides bounds even if the return type is unconstrained.
3915 if Is_Unc then
3916 declare
3917 First_Decl : Node_Id;
3919 begin
3920 First_Decl := First (Declarations (Blk));
3922 -- If the body is a single extended return statement,the
3923 -- resulting block is a nested block.
3925 if No (First_Decl) then
3926 First_Decl :=
3927 First (Statements (Handled_Statement_Sequence (Blk)));
3929 if Nkind (First_Decl) = N_Block_Statement then
3930 First_Decl := First (Declarations (First_Decl));
3931 end if;
3932 end if;
3934 -- No front-end inlining possible
3936 if Nkind (First_Decl) /= N_Object_Declaration then
3937 return;
3938 end if;
3940 if Nkind (Parent (N)) /= N_Assignment_Statement then
3941 Targ1 := Defining_Identifier (First_Decl);
3942 else
3943 Targ1 := Name (Parent (N));
3944 end if;
3945 end;
3946 end if;
3947 end;
3949 -- New semantics
3951 else
3952 declare
3953 Bod : Node_Id;
3955 begin
3956 -- General case
3958 if not Is_Unc then
3959 Bod :=
3960 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3961 Blk :=
3962 Make_Block_Statement (Loc,
3963 Declarations => Declarations (Bod),
3964 Handled_Statement_Sequence =>
3965 Handled_Statement_Sequence (Bod));
3967 -- Inline a call to a function that returns an unconstrained type.
3968 -- The semantic analyzer checked that frontend-inlined functions
3969 -- returning unconstrained types have no declarations and have
3970 -- a single extended return statement. As part of its processing
3971 -- the function was split into two subprograms: a procedure P' and
3972 -- a function F' that has a block with a call to procedure P' (see
3973 -- Split_Unconstrained_Function).
3975 else
3976 pragma Assert
3977 (Nkind
3978 (First
3979 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
3980 N_Block_Statement);
3982 declare
3983 Blk_Stmt : constant Node_Id :=
3984 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
3985 First_Stmt : constant Node_Id :=
3986 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
3987 Second_Stmt : constant Node_Id := Next (First_Stmt);
3989 begin
3990 pragma Assert
3991 (Nkind (First_Stmt) = N_Procedure_Call_Statement
3992 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3993 and then No (Next (Second_Stmt)));
3995 Bod :=
3996 Copy_Generic_Node
3997 (First
3998 (Statements (Handled_Statement_Sequence (Orig_Bod))),
3999 Empty, Instantiating => True);
4000 Blk := Bod;
4002 -- Capture the name of the local variable that holds the
4003 -- result. This must be the first declaration in the block,
4004 -- because its bounds cannot depend on local variables.
4005 -- Otherwise there is no way to declare the result outside
4006 -- of the block. Needless to say, in general the bounds will
4007 -- depend on the actuals in the call.
4009 if Nkind (Parent (N)) /= N_Assignment_Statement then
4010 Targ1 := Defining_Identifier (First (Declarations (Blk)));
4012 -- If the context is an assignment statement, as is the case
4013 -- for the expansion of an extended return, the left-hand
4014 -- side provides bounds even if the return type is
4015 -- unconstrained.
4017 else
4018 Targ1 := Name (Parent (N));
4019 end if;
4020 end;
4021 end if;
4023 if No (Declarations (Bod)) then
4024 Set_Declarations (Blk, New_List);
4025 end if;
4026 end;
4027 end if;
4029 -- If this is a derived function, establish the proper return type
4031 if Present (Orig_Subp) and then Orig_Subp /= Subp then
4032 Ret_Type := Etype (Orig_Subp);
4033 else
4034 Ret_Type := Etype (Subp);
4035 end if;
4037 -- Create temporaries for the actuals that are expressions, or that are
4038 -- scalars and require copying to preserve semantics.
4040 Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Orig_Bod);
4042 -- Establish target of function call. If context is not assignment or
4043 -- declaration, create a temporary as a target. The declaration for the
4044 -- temporary may be subsequently optimized away if the body is a single
4045 -- expression, or if the left-hand side of the assignment is simple
4046 -- enough, i.e. an entity or an explicit dereference of one.
4048 if Ekind (Subp) = E_Function then
4049 if Nkind (Parent (N)) = N_Assignment_Statement
4050 and then Is_Entity_Name (Name (Parent (N)))
4051 then
4052 Targ := Name (Parent (N));
4054 elsif Nkind (Parent (N)) = N_Assignment_Statement
4055 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
4056 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4057 then
4058 Targ := Name (Parent (N));
4060 elsif Nkind (Parent (N)) = N_Assignment_Statement
4061 and then Nkind (Name (Parent (N))) = N_Selected_Component
4062 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4063 then
4064 Targ := New_Copy_Tree (Name (Parent (N)));
4066 elsif Nkind (Parent (N)) = N_Object_Declaration
4067 and then Is_Limited_Type (Etype (Subp))
4068 then
4069 Targ := Defining_Identifier (Parent (N));
4071 -- New semantics: In an object declaration avoid an extra copy
4072 -- of the result of a call to an inlined function that returns
4073 -- an unconstrained type
4075 elsif Uses_Back_End
4076 and then Nkind (Parent (N)) = N_Object_Declaration
4077 and then Is_Unc
4078 then
4079 Targ := Defining_Identifier (Parent (N));
4081 else
4082 -- Replace call with temporary and create its declaration
4084 Temp := Make_Temporary (Loc, 'C');
4085 Set_Is_Internal (Temp);
4087 -- For the unconstrained case, the generated temporary has the
4088 -- same constrained declaration as the result variable. It may
4089 -- eventually be possible to remove that temporary and use the
4090 -- result variable directly.
4092 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
4093 then
4094 Decl :=
4095 Make_Object_Declaration (Loc,
4096 Defining_Identifier => Temp,
4097 Object_Definition =>
4098 New_Copy_Tree (Object_Definition (Parent (Targ1))));
4100 Replace_Formals (Decl);
4102 else
4103 Decl :=
4104 Make_Object_Declaration (Loc,
4105 Defining_Identifier => Temp,
4106 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
4108 Set_Etype (Temp, Ret_Type);
4109 end if;
4111 Set_No_Initialization (Decl);
4112 Append (Decl, Decls);
4113 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4114 Targ := Temp;
4115 end if;
4116 end if;
4118 Insert_Actions (N, Decls);
4120 if Is_Unc_Decl then
4122 -- Special management for inlining a call to a function that returns
4123 -- an unconstrained type and initializes an object declaration: we
4124 -- avoid generating undesired extra calls and goto statements.
4126 -- Given:
4127 -- function Func (...) return String is
4128 -- begin
4129 -- declare
4130 -- Result : String (1 .. 4);
4131 -- begin
4132 -- Proc (Result, ...);
4133 -- return Result;
4134 -- end;
4135 -- end Func;
4137 -- Result : String := Func (...);
4139 -- Replace this object declaration by:
4141 -- Result : String (1 .. 4);
4142 -- Proc (Result, ...);
4144 Remove_Homonym (Targ);
4146 Decl :=
4147 Make_Object_Declaration
4148 (Loc,
4149 Defining_Identifier => Targ,
4150 Object_Definition =>
4151 New_Copy_Tree (Object_Definition (Parent (Targ1))));
4152 Replace_Formals (Decl);
4153 Set_No_Initialization (Decl);
4154 Rewrite (Parent (N), Decl);
4155 Analyze (Parent (N));
4157 -- Avoid spurious warnings since we know that this declaration is
4158 -- referenced by the procedure call.
4160 Set_Never_Set_In_Source (Targ, False);
4162 -- Remove the local declaration of the extended return stmt from the
4163 -- inlined code
4165 Remove (Parent (Targ1));
4167 -- Update the reference to the result (since we have rewriten the
4168 -- object declaration)
4170 declare
4171 Blk_Call_Stmt : Node_Id;
4173 begin
4174 -- Capture the call to the procedure
4176 Blk_Call_Stmt :=
4177 First (Statements (Handled_Statement_Sequence (Blk)));
4178 pragma Assert
4179 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
4181 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
4182 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
4183 New_Occurrence_Of (Targ, Loc));
4184 end;
4186 -- Remove the return statement
4188 pragma Assert
4189 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
4190 N_Simple_Return_Statement);
4192 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
4193 end if;
4195 -- Traverse the tree and replace formals with actuals or their thunks.
4196 -- Attach block to tree before analysis and rewriting.
4198 Replace_Formals (Blk);
4199 Replace_Formals_In_Aspects (Blk);
4200 Set_Parent (Blk, N);
4202 if GNATprove_Mode then
4203 null;
4205 elsif not Comes_From_Source (Subp) or else Is_Predef then
4206 Reset_Slocs (Blk);
4207 end if;
4209 if Is_Unc_Decl then
4211 -- No action needed since return statement has been already removed
4213 null;
4215 elsif Present (Exit_Lab) then
4217 -- If there's a single return statement at the end of the subprogram,
4218 -- the corresponding goto statement and the corresponding label are
4219 -- useless.
4221 if Num_Ret = 1
4222 and then
4223 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
4224 N_Goto_Statement
4225 then
4226 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
4227 else
4228 Append (Lab_Decl, (Declarations (Blk)));
4229 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
4230 end if;
4231 end if;
4233 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
4234 -- on conflicting private views that Gigi would ignore. If this is a
4235 -- predefined unit, analyze with checks off, as is done in the non-
4236 -- inlined run-time units.
4238 declare
4239 I_Flag : constant Boolean := In_Inlined_Body;
4241 begin
4242 In_Inlined_Body := True;
4244 if Is_Predef then
4245 declare
4246 Style : constant Boolean := Style_Check;
4248 begin
4249 Style_Check := False;
4251 -- Search for dispatching calls that use the Object.Operation
4252 -- notation using an Object that is a parameter of the inlined
4253 -- function. We reset the decoration of Operation to force
4254 -- the reanalysis of the inlined dispatching call because
4255 -- the actual object has been inlined.
4257 Reset_Dispatching_Calls (Blk);
4259 -- In GNATprove mode, always consider checks on, even for
4260 -- predefined units.
4262 if GNATprove_Mode then
4263 Analyze (Blk);
4264 else
4265 Analyze (Blk, Suppress => All_Checks);
4266 end if;
4268 Style_Check := Style;
4269 end;
4271 else
4272 Analyze (Blk);
4273 end if;
4275 In_Inlined_Body := I_Flag;
4276 end;
4278 if Ekind (Subp) = E_Procedure then
4279 Rewrite_Procedure_Call (N, Blk);
4281 else
4282 Rewrite_Function_Call (N, Blk);
4284 if Is_Unc_Decl then
4285 null;
4287 -- For the unconstrained case, the replacement of the call has been
4288 -- made prior to the complete analysis of the generated declarations.
4289 -- Propagate the proper type now.
4291 elsif Is_Unc then
4292 if Nkind (N) = N_Identifier then
4293 Set_Etype (N, Etype (Entity (N)));
4294 else
4295 Set_Etype (N, Etype (Targ1));
4296 end if;
4297 end if;
4298 end if;
4300 Restore_Env;
4302 -- Cleanup mapping between formals and actuals for other expansions
4304 Reset_Actual_Mapping_For_Inlined_Call (Subp);
4305 end Expand_Inlined_Call;
4307 --------------------------
4308 -- Get_Code_Unit_Entity --
4309 --------------------------
4311 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
4312 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
4314 begin
4315 if Ekind (Unit) = E_Package_Body then
4316 Unit := Spec_Entity (Unit);
4317 end if;
4319 return Unit;
4320 end Get_Code_Unit_Entity;
4322 ------------------------------
4323 -- Has_Excluded_Declaration --
4324 ------------------------------
4326 function Has_Excluded_Declaration
4327 (Subp : Entity_Id;
4328 Decls : List_Id) return Boolean
4330 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
4331 -- Nested subprograms make a given body ineligible for inlining, but
4332 -- we make an exception for instantiations of unchecked conversion.
4333 -- The body has not been analyzed yet, so check the name, and verify
4334 -- that the visible entity with that name is the predefined unit.
4336 -----------------------------
4337 -- Is_Unchecked_Conversion --
4338 -----------------------------
4340 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
4341 Id : constant Node_Id := Name (D);
4342 Conv : Entity_Id;
4344 begin
4345 if Nkind (Id) = N_Identifier
4346 and then Chars (Id) = Name_Unchecked_Conversion
4347 then
4348 Conv := Current_Entity (Id);
4350 elsif Nkind (Id) in N_Selected_Component | N_Expanded_Name
4351 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
4352 then
4353 Conv := Current_Entity (Selector_Name (Id));
4354 else
4355 return False;
4356 end if;
4358 return Present (Conv)
4359 and then Is_Predefined_Unit (Get_Source_Unit (Conv))
4360 and then Is_Intrinsic_Subprogram (Conv);
4361 end Is_Unchecked_Conversion;
4363 -- Local variables
4365 Decl : Node_Id;
4367 -- Start of processing for Has_Excluded_Declaration
4369 begin
4370 -- No action needed if the check is not needed
4372 if not Check_Inlining_Restrictions then
4373 return False;
4374 end if;
4376 Decl := First (Decls);
4377 while Present (Decl) loop
4379 -- First declarations universally excluded
4381 if Nkind (Decl) = N_Package_Declaration then
4382 Cannot_Inline
4383 ("cannot inline & (nested package declaration)?", Decl, Subp);
4384 return True;
4386 elsif Nkind (Decl) = N_Package_Instantiation then
4387 Cannot_Inline
4388 ("cannot inline & (nested package instantiation)?", Decl, Subp);
4389 return True;
4390 end if;
4392 -- Then declarations excluded only for front-end inlining
4394 if Back_End_Inlining then
4395 null;
4397 elsif Nkind (Decl) = N_Task_Type_Declaration
4398 or else Nkind (Decl) = N_Single_Task_Declaration
4399 then
4400 Cannot_Inline
4401 ("cannot inline & (nested task type declaration)?", Decl, Subp);
4402 return True;
4404 elsif Nkind (Decl) in N_Protected_Type_Declaration
4405 | N_Single_Protected_Declaration
4406 then
4407 Cannot_Inline
4408 ("cannot inline & (nested protected type declaration)?",
4409 Decl, Subp);
4410 return True;
4412 elsif Nkind (Decl) = N_Subprogram_Body then
4413 Cannot_Inline
4414 ("cannot inline & (nested subprogram)?", Decl, Subp);
4415 return True;
4417 elsif Nkind (Decl) = N_Function_Instantiation
4418 and then not Is_Unchecked_Conversion (Decl)
4419 then
4420 Cannot_Inline
4421 ("cannot inline & (nested function instantiation)?", Decl, Subp);
4422 return True;
4424 elsif Nkind (Decl) = N_Procedure_Instantiation then
4425 Cannot_Inline
4426 ("cannot inline & (nested procedure instantiation)?",
4427 Decl, Subp);
4428 return True;
4430 -- Subtype declarations with predicates will generate predicate
4431 -- functions, i.e. nested subprogram bodies, so inlining is not
4432 -- possible.
4434 elsif Nkind (Decl) = N_Subtype_Declaration then
4435 declare
4436 A : Node_Id;
4437 A_Id : Aspect_Id;
4439 begin
4440 A := First (Aspect_Specifications (Decl));
4441 while Present (A) loop
4442 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
4444 if A_Id = Aspect_Predicate
4445 or else A_Id = Aspect_Static_Predicate
4446 or else A_Id = Aspect_Dynamic_Predicate
4447 then
4448 Cannot_Inline
4449 ("cannot inline & (subtype declaration with "
4450 & "predicate)?", Decl, Subp);
4451 return True;
4452 end if;
4454 Next (A);
4455 end loop;
4456 end;
4457 end if;
4459 Next (Decl);
4460 end loop;
4462 return False;
4463 end Has_Excluded_Declaration;
4465 ----------------------------
4466 -- Has_Excluded_Statement --
4467 ----------------------------
4469 function Has_Excluded_Statement
4470 (Subp : Entity_Id;
4471 Stats : List_Id) return Boolean
4473 S : Node_Id;
4474 E : Node_Id;
4476 begin
4477 -- No action needed if the check is not needed
4479 if not Check_Inlining_Restrictions then
4480 return False;
4481 end if;
4483 S := First (Stats);
4484 while Present (S) loop
4485 if Nkind (S) in N_Abort_Statement
4486 | N_Asynchronous_Select
4487 | N_Conditional_Entry_Call
4488 | N_Delay_Relative_Statement
4489 | N_Delay_Until_Statement
4490 | N_Selective_Accept
4491 | N_Timed_Entry_Call
4492 then
4493 Cannot_Inline
4494 ("cannot inline & (non-allowed statement)?", S, Subp);
4495 return True;
4497 elsif Nkind (S) = N_Block_Statement then
4498 if Has_Excluded_Declaration (Subp, Declarations (S)) then
4499 return True;
4501 elsif Present (Handled_Statement_Sequence (S)) then
4502 if not Back_End_Inlining
4503 and then
4504 Present
4505 (Exception_Handlers (Handled_Statement_Sequence (S)))
4506 then
4507 Cannot_Inline
4508 ("cannot inline& (exception handler)?",
4509 First (Exception_Handlers
4510 (Handled_Statement_Sequence (S))),
4511 Subp);
4512 return True;
4514 elsif Has_Excluded_Statement
4515 (Subp, Statements (Handled_Statement_Sequence (S)))
4516 then
4517 return True;
4518 end if;
4519 end if;
4521 elsif Nkind (S) = N_Case_Statement then
4522 E := First (Alternatives (S));
4523 while Present (E) loop
4524 if Has_Excluded_Statement (Subp, Statements (E)) then
4525 return True;
4526 end if;
4528 Next (E);
4529 end loop;
4531 elsif Nkind (S) = N_If_Statement then
4532 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
4533 return True;
4534 end if;
4536 if Present (Elsif_Parts (S)) then
4537 E := First (Elsif_Parts (S));
4538 while Present (E) loop
4539 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
4540 return True;
4541 end if;
4543 Next (E);
4544 end loop;
4545 end if;
4547 if Present (Else_Statements (S))
4548 and then Has_Excluded_Statement (Subp, Else_Statements (S))
4549 then
4550 return True;
4551 end if;
4553 elsif Nkind (S) = N_Loop_Statement
4554 and then Has_Excluded_Statement (Subp, Statements (S))
4555 then
4556 return True;
4558 elsif Nkind (S) = N_Extended_Return_Statement then
4559 if Present (Handled_Statement_Sequence (S))
4560 and then
4561 Has_Excluded_Statement
4562 (Subp, Statements (Handled_Statement_Sequence (S)))
4563 then
4564 return True;
4566 elsif not Back_End_Inlining
4567 and then Present (Handled_Statement_Sequence (S))
4568 and then
4569 Present (Exception_Handlers
4570 (Handled_Statement_Sequence (S)))
4571 then
4572 Cannot_Inline
4573 ("cannot inline& (exception handler)?",
4574 First (Exception_Handlers (Handled_Statement_Sequence (S))),
4575 Subp);
4576 return True;
4577 end if;
4578 end if;
4580 Next (S);
4581 end loop;
4583 return False;
4584 end Has_Excluded_Statement;
4586 --------------------------
4587 -- Has_Initialized_Type --
4588 --------------------------
4590 function Has_Initialized_Type (E : Entity_Id) return Boolean is
4591 E_Body : constant Node_Id := Subprogram_Body (E);
4592 Decl : Node_Id;
4594 begin
4595 if No (E_Body) then -- imported subprogram
4596 return False;
4598 else
4599 Decl := First (Declarations (E_Body));
4600 while Present (Decl) loop
4601 if Nkind (Decl) = N_Full_Type_Declaration
4602 and then Comes_From_Source (Decl)
4603 and then Present (Init_Proc (Defining_Identifier (Decl)))
4604 then
4605 return True;
4606 end if;
4608 Next (Decl);
4609 end loop;
4610 end if;
4612 return False;
4613 end Has_Initialized_Type;
4615 -----------------------
4616 -- Has_Single_Return --
4617 -----------------------
4619 function Has_Single_Return (N : Node_Id) return Boolean is
4620 Return_Statement : Node_Id := Empty;
4622 function Check_Return (N : Node_Id) return Traverse_Result;
4624 ------------------
4625 -- Check_Return --
4626 ------------------
4628 function Check_Return (N : Node_Id) return Traverse_Result is
4629 begin
4630 if Nkind (N) = N_Simple_Return_Statement then
4631 if Present (Expression (N))
4632 and then Is_Entity_Name (Expression (N))
4633 then
4634 pragma Assert (Present (Entity (Expression (N))));
4636 if No (Return_Statement) then
4637 Return_Statement := N;
4638 return OK;
4640 else
4641 pragma Assert
4642 (Present (Entity (Expression (Return_Statement))));
4644 if Entity (Expression (N)) =
4645 Entity (Expression (Return_Statement))
4646 then
4647 return OK;
4648 else
4649 return Abandon;
4650 end if;
4651 end if;
4653 -- A return statement within an extended return is a noop after
4654 -- inlining.
4656 elsif No (Expression (N))
4657 and then Nkind (Parent (Parent (N))) =
4658 N_Extended_Return_Statement
4659 then
4660 return OK;
4662 else
4663 -- Expression has wrong form
4665 return Abandon;
4666 end if;
4668 -- We can only inline a build-in-place function if it has a single
4669 -- extended return.
4671 elsif Nkind (N) = N_Extended_Return_Statement then
4672 if No (Return_Statement) then
4673 Return_Statement := N;
4674 return OK;
4676 else
4677 return Abandon;
4678 end if;
4680 else
4681 return OK;
4682 end if;
4683 end Check_Return;
4685 function Check_All_Returns is new Traverse_Func (Check_Return);
4687 -- Start of processing for Has_Single_Return
4689 begin
4690 if Check_All_Returns (N) /= OK then
4691 return False;
4693 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
4694 return True;
4696 else
4697 return
4698 Present (Declarations (N))
4699 and then Present (First (Declarations (N)))
4700 and then Nkind (First (Declarations (N))) = N_Object_Declaration
4701 and then Entity (Expression (Return_Statement)) =
4702 Defining_Identifier (First (Declarations (N)));
4703 end if;
4704 end Has_Single_Return;
4706 -----------------------------
4707 -- In_Main_Unit_Or_Subunit --
4708 -----------------------------
4710 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
4711 Comp : Node_Id := Cunit (Get_Code_Unit (E));
4713 begin
4714 -- Check whether the subprogram or package to inline is within the main
4715 -- unit or its spec or within a subunit. In either case there are no
4716 -- additional bodies to process. If the subprogram appears in a parent
4717 -- of the current unit, the check on whether inlining is possible is
4718 -- done in Analyze_Inlined_Bodies.
4720 while Nkind (Unit (Comp)) = N_Subunit loop
4721 Comp := Library_Unit (Comp);
4722 end loop;
4724 return Comp = Cunit (Main_Unit)
4725 or else Comp = Library_Unit (Cunit (Main_Unit));
4726 end In_Main_Unit_Or_Subunit;
4728 ----------------
4729 -- Initialize --
4730 ----------------
4732 procedure Initialize is
4733 begin
4734 Pending_Instantiations.Init;
4735 Called_Pending_Instantiations.Init;
4736 Inlined_Bodies.Init;
4737 Successors.Init;
4738 Inlined.Init;
4740 for J in Hash_Headers'Range loop
4741 Hash_Headers (J) := No_Subp;
4742 end loop;
4744 Inlined_Calls := No_Elist;
4745 Backend_Calls := No_Elist;
4746 Backend_Instances := No_Elist;
4747 Backend_Inlined_Subps := No_Elist;
4748 Backend_Not_Inlined_Subps := No_Elist;
4749 end Initialize;
4751 ---------------------------------
4752 -- Inline_Static_Function_Call --
4753 ---------------------------------
4755 procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is
4757 function Replace_Formal (N : Node_Id) return Traverse_Result;
4758 -- Replace each occurrence of a formal with the
4759 -- corresponding actual, using the mapping created
4760 -- by Establish_Actual_Mapping_For_Inlined_Call.
4762 function Reset_Sloc (Nod : Node_Id) return Traverse_Result;
4763 -- Reset the Sloc of a node to that of the call itself, so that errors
4764 -- will be flagged on the call to the static expression function itself
4765 -- rather than on the expression of the function's declaration.
4767 --------------------
4768 -- Replace_Formal --
4769 --------------------
4771 function Replace_Formal (N : Node_Id) return Traverse_Result is
4772 A : Entity_Id;
4773 E : Entity_Id;
4775 begin
4776 if Is_Entity_Name (N) and then Present (Entity (N)) then
4777 E := Entity (N);
4779 if Is_Formal (E) and then Scope (E) = Subp then
4780 A := Renamed_Object (E);
4782 if Nkind (A) = N_Defining_Identifier then
4783 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
4785 -- Literal cases
4787 else
4788 Rewrite (N, New_Copy (A));
4789 end if;
4790 end if;
4792 return Skip;
4794 else
4795 return OK;
4796 end if;
4797 end Replace_Formal;
4799 procedure Replace_Formals is new Traverse_Proc (Replace_Formal);
4801 ------------------
4802 -- Process_Sloc --
4803 ------------------
4805 function Reset_Sloc (Nod : Node_Id) return Traverse_Result is
4806 begin
4807 Set_Sloc (Nod, Sloc (N));
4808 Set_Comes_From_Source (Nod, False);
4810 return OK;
4811 end Reset_Sloc;
4813 procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc);
4815 -- Start of processing for Inline_Static_Function_Call
4817 begin
4818 pragma Assert (Is_Static_Function_Call (N));
4820 declare
4821 Decls : constant List_Id := New_List;
4822 Func_Expr : constant Node_Id :=
4823 Expression_Of_Expression_Function (Subp);
4824 Expr_Copy : constant Node_Id := New_Copy_Tree (Func_Expr);
4826 begin
4827 -- Create a mapping from formals to actuals, also creating temps in
4828 -- Decls, when needed, to hold the actuals.
4830 Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Func_Expr);
4832 -- Ensure that the copy has the same parent as the call (this seems
4833 -- to matter when GNATprove_Mode is set and there are nested static
4834 -- calls; prevents blowups in Insert_Actions, though it's not clear
4835 -- exactly why this is needed???).
4837 Set_Parent (Expr_Copy, Parent (N));
4839 Insert_Actions (N, Decls);
4841 -- Now substitute actuals for their corresponding formal references
4842 -- within the expression.
4844 Replace_Formals (Expr_Copy);
4846 Reset_Slocs (Expr_Copy);
4848 -- Apply a qualified expression with the function's result subtype,
4849 -- to ensure that we check the expression against any constraint
4850 -- or predicate, which will cause the call to be illegal if the
4851 -- folded expression doesn't satisfy them. (The predicate case
4852 -- might not get checked if the subtype hasn't been frozen yet,
4853 -- which can happen if this static expression happens to be what
4854 -- causes the freezing, because Has_Static_Predicate doesn't get
4855 -- set on the subtype until it's frozen and Build_Predicates is
4856 -- called. It's not clear how to address this case. ???)
4858 Rewrite (Expr_Copy,
4859 Make_Qualified_Expression (Sloc (Expr_Copy),
4860 Subtype_Mark =>
4861 New_Occurrence_Of (Etype (N), Sloc (Expr_Copy)),
4862 Expression =>
4863 Relocate_Node (Expr_Copy)));
4865 Set_Etype (Expr_Copy, Etype (N));
4867 Analyze_And_Resolve (Expr_Copy, Etype (N));
4869 -- Finally rewrite the function call as the folded static result
4871 Rewrite (N, Expr_Copy);
4873 -- Cleanup mapping between formals and actuals for other expansions
4875 Reset_Actual_Mapping_For_Inlined_Call (Subp);
4876 end;
4877 end Inline_Static_Function_Call;
4879 ------------------------
4880 -- Instantiate_Bodies --
4881 ------------------------
4883 -- Generic bodies contain all the non-local references, so an
4884 -- instantiation does not need any more context than Standard
4885 -- itself, even if the instantiation appears in an inner scope.
4886 -- Generic associations have verified that the contract model is
4887 -- satisfied, so that any error that may occur in the analysis of
4888 -- the body is an internal error.
4890 procedure Instantiate_Bodies is
4892 procedure Instantiate_Body (Info : Pending_Body_Info);
4893 -- Instantiate a pending body
4895 ------------------------
4896 -- Instantiate_Body --
4897 ------------------------
4899 procedure Instantiate_Body (Info : Pending_Body_Info) is
4900 Scop : Entity_Id;
4902 begin
4903 -- If the instantiation node is absent, it has been removed as part
4904 -- of unreachable code.
4906 if No (Info.Inst_Node) then
4907 null;
4909 -- If the instantiation node is a package body, this means that the
4910 -- instance is a compilation unit and the instantiation has already
4911 -- been performed by Build_Instance_Compilation_Unit_Nodes.
4913 elsif Nkind (Info.Inst_Node) = N_Package_Body then
4914 null;
4916 -- For other package instances, instantiate the body and register the
4917 -- finalization scope, if any, for subsequent generation of cleanups.
4919 elsif Nkind (Info.Inst_Node) = N_Package_Instantiation then
4921 -- If the enclosing finalization scope is a package body, set the
4922 -- In_Package_Body flag on its spec. This is required, in the case
4923 -- where the body contains other package instantiations that have
4924 -- a body, for Analyze_Package_Instantiation to compute a correct
4925 -- finalization scope.
4927 if Present (Info.Fin_Scop)
4928 and then Ekind (Info.Fin_Scop) = E_Package_Body
4929 then
4930 Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True);
4931 end if;
4933 Instantiate_Package_Body (Info);
4935 if Present (Info.Fin_Scop) then
4936 Scop := Info.Fin_Scop;
4938 -- If the enclosing finalization scope is dynamic, the instance
4939 -- may have been relocated, for example if it was declared in a
4940 -- protected entry, protected subprogram, or task body.
4942 if Is_Dynamic_Scope (Scop) then
4943 Scop :=
4944 Enclosing_Dynamic_Scope (Defining_Entity (Info.Act_Decl));
4945 end if;
4947 Add_Scope_To_Clean (Scop);
4949 -- Reset the In_Package_Body flag if it was set above
4951 if Ekind (Info.Fin_Scop) = E_Package_Body then
4952 Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False);
4953 end if;
4954 end if;
4956 -- For subprogram instances, always instantiate the body
4958 else
4959 Instantiate_Subprogram_Body (Info);
4960 end if;
4961 end Instantiate_Body;
4963 J, K : Nat;
4964 Info : Pending_Body_Info;
4966 -- Start of processing for Instantiate_Bodies
4968 begin
4969 if Serious_Errors_Detected = 0 then
4970 Expander_Active := (Operating_Mode = Opt.Generate_Code);
4971 Push_Scope (Standard_Standard);
4972 To_Clean := New_Elmt_List;
4974 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
4975 Start_Generic;
4976 end if;
4978 -- A body instantiation may generate additional instantiations, so
4979 -- the following loop must scan to the end of a possibly expanding
4980 -- set (that's why we cannot simply use a FOR loop here). We must
4981 -- also capture the element lest the set be entirely reallocated.
4983 J := 0;
4984 if Back_End_Inlining then
4985 while J <= Called_Pending_Instantiations.Last
4986 and then Serious_Errors_Detected = 0
4987 loop
4988 K := Called_Pending_Instantiations.Table (J);
4989 Info := Pending_Instantiations.Table (K);
4990 Instantiate_Body (Info);
4992 J := J + 1;
4993 end loop;
4995 else
4996 while J <= Pending_Instantiations.Last
4997 and then Serious_Errors_Detected = 0
4998 loop
4999 Info := Pending_Instantiations.Table (J);
5000 Instantiate_Body (Info);
5002 J := J + 1;
5003 end loop;
5004 end if;
5006 -- Reset the table of instantiations. Additional instantiations
5007 -- may be added through inlining, when additional bodies are
5008 -- analyzed.
5010 if Back_End_Inlining then
5011 Called_Pending_Instantiations.Init;
5012 else
5013 Pending_Instantiations.Init;
5014 end if;
5016 -- We can now complete the cleanup actions of scopes that contain
5017 -- pending instantiations (skipped for generic units, since we
5018 -- never need any cleanups in generic units).
5020 if Expander_Active
5021 and then not Is_Generic_Unit (Main_Unit_Entity)
5022 then
5023 Cleanup_Scopes;
5024 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
5025 End_Generic;
5026 end if;
5028 Pop_Scope;
5029 end if;
5030 end Instantiate_Bodies;
5032 ---------------
5033 -- Is_Nested --
5034 ---------------
5036 function Is_Nested (E : Entity_Id) return Boolean is
5037 Scop : Entity_Id;
5039 begin
5040 Scop := Scope (E);
5041 while Scop /= Standard_Standard loop
5042 if Is_Subprogram (Scop) then
5043 return True;
5045 elsif Ekind (Scop) = E_Task_Type
5046 or else Ekind (Scop) = E_Entry
5047 or else Ekind (Scop) = E_Entry_Family
5048 then
5049 return True;
5050 end if;
5052 Scop := Scope (Scop);
5053 end loop;
5055 return False;
5056 end Is_Nested;
5058 ------------------------
5059 -- List_Inlining_Info --
5060 ------------------------
5062 procedure List_Inlining_Info is
5063 Elmt : Elmt_Id;
5064 Nod : Node_Id;
5065 Count : Nat;
5067 begin
5068 if not Debug_Flag_Dot_J then
5069 return;
5070 end if;
5072 -- Generate listing of calls inlined by the frontend
5074 if Present (Inlined_Calls) then
5075 Count := 0;
5076 Elmt := First_Elmt (Inlined_Calls);
5077 while Present (Elmt) loop
5078 Nod := Node (Elmt);
5080 if not In_Internal_Unit (Nod) then
5081 Count := Count + 1;
5083 if Count = 1 then
5084 Write_Str ("List of calls inlined by the frontend");
5085 Write_Eol;
5086 end if;
5088 Write_Str (" ");
5089 Write_Int (Count);
5090 Write_Str (":");
5091 Write_Location (Sloc (Nod));
5092 Write_Str (":");
5093 Output.Write_Eol;
5094 end if;
5096 Next_Elmt (Elmt);
5097 end loop;
5098 end if;
5100 -- Generate listing of calls passed to the backend
5102 if Present (Backend_Calls) then
5103 Count := 0;
5105 Elmt := First_Elmt (Backend_Calls);
5106 while Present (Elmt) loop
5107 Nod := Node (Elmt);
5109 if not In_Internal_Unit (Nod) then
5110 Count := Count + 1;
5112 if Count = 1 then
5113 Write_Str ("List of inlined calls passed to the backend");
5114 Write_Eol;
5115 end if;
5117 Write_Str (" ");
5118 Write_Int (Count);
5119 Write_Str (":");
5120 Write_Location (Sloc (Nod));
5121 Output.Write_Eol;
5122 end if;
5124 Next_Elmt (Elmt);
5125 end loop;
5126 end if;
5128 -- Generate listing of instances inlined for the backend
5130 if Present (Backend_Instances) then
5131 Count := 0;
5133 Elmt := First_Elmt (Backend_Instances);
5134 while Present (Elmt) loop
5135 Nod := Node (Elmt);
5137 if not In_Internal_Unit (Nod) then
5138 Count := Count + 1;
5140 if Count = 1 then
5141 Write_Str ("List of instances inlined for the backend");
5142 Write_Eol;
5143 end if;
5145 Write_Str (" ");
5146 Write_Int (Count);
5147 Write_Str (":");
5148 Write_Location (Sloc (Nod));
5149 Output.Write_Eol;
5150 end if;
5152 Next_Elmt (Elmt);
5153 end loop;
5154 end if;
5156 -- Generate listing of subprograms passed to the backend
5158 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
5159 Count := 0;
5161 Elmt := First_Elmt (Backend_Inlined_Subps);
5162 while Present (Elmt) loop
5163 Nod := Node (Elmt);
5165 if not In_Internal_Unit (Nod) then
5166 Count := Count + 1;
5168 if Count = 1 then
5169 Write_Str
5170 ("List of inlined subprograms passed to the backend");
5171 Write_Eol;
5172 end if;
5174 Write_Str (" ");
5175 Write_Int (Count);
5176 Write_Str (":");
5177 Write_Name (Chars (Nod));
5178 Write_Str (" (");
5179 Write_Location (Sloc (Nod));
5180 Write_Str (")");
5181 Output.Write_Eol;
5182 end if;
5184 Next_Elmt (Elmt);
5185 end loop;
5186 end if;
5188 -- Generate listing of subprograms that cannot be inlined by the backend
5190 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
5191 Count := 0;
5193 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
5194 while Present (Elmt) loop
5195 Nod := Node (Elmt);
5197 if not In_Internal_Unit (Nod) then
5198 Count := Count + 1;
5200 if Count = 1 then
5201 Write_Str
5202 ("List of subprograms that cannot be inlined by backend");
5203 Write_Eol;
5204 end if;
5206 Write_Str (" ");
5207 Write_Int (Count);
5208 Write_Str (":");
5209 Write_Name (Chars (Nod));
5210 Write_Str (" (");
5211 Write_Location (Sloc (Nod));
5212 Write_Str (")");
5213 Output.Write_Eol;
5214 end if;
5216 Next_Elmt (Elmt);
5217 end loop;
5218 end if;
5219 end List_Inlining_Info;
5221 ----------
5222 -- Lock --
5223 ----------
5225 procedure Lock is
5226 begin
5227 Pending_Instantiations.Release;
5228 Pending_Instantiations.Locked := True;
5229 Called_Pending_Instantiations.Release;
5230 Called_Pending_Instantiations.Locked := True;
5231 Inlined_Bodies.Release;
5232 Inlined_Bodies.Locked := True;
5233 Successors.Release;
5234 Successors.Locked := True;
5235 Inlined.Release;
5236 Inlined.Locked := True;
5237 end Lock;
5239 --------------------------------
5240 -- Remove_Aspects_And_Pragmas --
5241 --------------------------------
5243 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
5244 procedure Remove_Items (List : List_Id);
5245 -- Remove all useless aspects/pragmas from a particular list
5247 ------------------
5248 -- Remove_Items --
5249 ------------------
5251 procedure Remove_Items (List : List_Id) is
5252 Item : Node_Id;
5253 Item_Id : Node_Id;
5254 Next_Item : Node_Id;
5256 begin
5257 -- Traverse the list looking for an aspect specification or a pragma
5259 Item := First (List);
5260 while Present (Item) loop
5261 Next_Item := Next (Item);
5263 if Nkind (Item) = N_Aspect_Specification then
5264 Item_Id := Identifier (Item);
5265 elsif Nkind (Item) = N_Pragma then
5266 Item_Id := Pragma_Identifier (Item);
5267 else
5268 Item_Id := Empty;
5269 end if;
5271 if Present (Item_Id)
5272 and then Chars (Item_Id) in Name_Always_Terminates
5273 | Name_Contract_Cases
5274 | Name_Global
5275 | Name_Depends
5276 | Name_Exceptional_Cases
5277 | Name_Postcondition
5278 | Name_Precondition
5279 | Name_Refined_Global
5280 | Name_Refined_Depends
5281 | Name_Refined_Post
5282 | Name_Subprogram_Variant
5283 | Name_Test_Case
5284 | Name_Unmodified
5285 | Name_Unreferenced
5286 | Name_Unused
5287 then
5288 Remove (Item);
5289 end if;
5291 Item := Next_Item;
5292 end loop;
5293 end Remove_Items;
5295 -- Start of processing for Remove_Aspects_And_Pragmas
5297 begin
5298 Remove_Items (Aspect_Specifications (Body_Decl));
5299 Remove_Items (Declarations (Body_Decl));
5301 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
5302 -- in the body of the subprogram.
5304 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
5305 end Remove_Aspects_And_Pragmas;
5307 --------------------------
5308 -- Remove_Dead_Instance --
5309 --------------------------
5311 procedure Remove_Dead_Instance (N : Node_Id) is
5312 begin
5313 for J in 0 .. Pending_Instantiations.Last loop
5314 if Pending_Instantiations.Table (J).Inst_Node = N then
5315 Pending_Instantiations.Table (J).Inst_Node := Empty;
5316 return;
5317 end if;
5318 end loop;
5319 end Remove_Dead_Instance;
5321 -------------------------------------------
5322 -- Reset_Actual_Mapping_For_Inlined_Call --
5323 -------------------------------------------
5325 procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id) is
5326 F : Entity_Id := First_Formal (Subp);
5328 begin
5329 while Present (F) loop
5330 Set_Renamed_Object (F, Empty);
5331 Next_Formal (F);
5332 end loop;
5333 end Reset_Actual_Mapping_For_Inlined_Call;
5335 end Inline;