File : inline.adb
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-2016, 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 ------------------------------------------------------------------------------
25
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Expander; use Expander;
33 with Exp_Ch6; use Exp_Ch6;
34 with Exp_Ch7; use Exp_Ch7;
35 with Exp_Tss; use Exp_Tss;
36 with Exp_Util; use Exp_Util;
37 with Fname; use Fname;
38 with Fname.UF; use Fname.UF;
39 with Lib; use Lib;
40 with Namet; use Namet;
41 with Nmake; use Nmake;
42 with Nlists; use Nlists;
43 with Output; use Output;
44 with Sem_Aux; use Sem_Aux;
45 with Sem_Ch8; use Sem_Ch8;
46 with Sem_Ch10; use Sem_Ch10;
47 with Sem_Ch12; use Sem_Ch12;
48 with Sem_Prag; use Sem_Prag;
49 with Sem_Util; use Sem_Util;
50 with Sinfo; use Sinfo;
51 with Sinput; use Sinput;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Uname; use Uname;
55 with Tbuild; use Tbuild;
56
57 package body Inline is
58
59 Check_Inlining_Restrictions : constant Boolean := True;
60 -- In the following cases the frontend rejects inlining because they
61 -- are not handled well by the backend. This variable facilitates
62 -- disabling these restrictions to evaluate future versions of the
63 -- GCC backend in which some of the restrictions may be supported.
64 --
65 -- - subprograms that have:
66 -- - nested subprograms
67 -- - instantiations
68 -- - package declarations
69 -- - task or protected object declarations
70 -- - some of the following statements:
71 -- - abort
72 -- - asynchronous-select
73 -- - conditional-entry-call
74 -- - delay-relative
75 -- - delay-until
76 -- - selective-accept
77 -- - timed-entry-call
78
79 Inlined_Calls : Elist_Id;
80 -- List of frontend inlined calls
81
82 Backend_Calls : Elist_Id;
83 -- List of inline calls passed to the backend
84
85 Backend_Inlined_Subps : Elist_Id;
86 -- List of subprograms inlined by the backend
87
88 Backend_Not_Inlined_Subps : Elist_Id;
89 -- List of subprograms that cannot be inlined by the backend
90
91 --------------------
92 -- Inlined Bodies --
93 --------------------
94
95 -- Inlined functions are actually placed in line by the backend if the
96 -- corresponding bodies are available (i.e. compiled). Whenever we find
97 -- a call to an inlined subprogram, we add the name of the enclosing
98 -- compilation unit to a worklist. After all compilation, and after
99 -- expansion of generic bodies, we traverse the list of pending bodies
100 -- and compile them as well.
101
102 package Inlined_Bodies is new Table.Table (
103 Table_Component_Type => Entity_Id,
104 Table_Index_Type => Int,
105 Table_Low_Bound => 0,
106 Table_Initial => Alloc.Inlined_Bodies_Initial,
107 Table_Increment => Alloc.Inlined_Bodies_Increment,
108 Table_Name => "Inlined_Bodies");
109
110 -----------------------
111 -- Inline Processing --
112 -----------------------
113
114 -- For each call to an inlined subprogram, we make entries in a table
115 -- that stores caller and callee, and indicates the call direction from
116 -- one to the other. We also record the compilation unit that contains
117 -- the callee. After analyzing the bodies of all such compilation units,
118 -- we compute the transitive closure of inlined subprograms called from
119 -- the main compilation unit and make it available to the code generator
120 -- in no particular order, thus allowing cycles in the call graph.
121
122 Last_Inlined : Entity_Id := Empty;
123
124 -- For each entry in the table we keep a list of successors in topological
125 -- order, i.e. callers of the current subprogram.
126
127 type Subp_Index is new Nat;
128 No_Subp : constant Subp_Index := 0;
129
130 -- The subprogram entities are hashed into the Inlined table
131
132 Num_Hash_Headers : constant := 512;
133
134 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
135 of Subp_Index;
136
137 type Succ_Index is new Nat;
138 No_Succ : constant Succ_Index := 0;
139
140 type Succ_Info is record
141 Subp : Subp_Index;
142 Next : Succ_Index;
143 end record;
144
145 -- The following table stores list elements for the successor lists. These
146 -- lists cannot be chained directly through entries in the Inlined table,
147 -- because a given subprogram can appear in several such lists.
148
149 package Successors is new Table.Table (
150 Table_Component_Type => Succ_Info,
151 Table_Index_Type => Succ_Index,
152 Table_Low_Bound => 1,
153 Table_Initial => Alloc.Successors_Initial,
154 Table_Increment => Alloc.Successors_Increment,
155 Table_Name => "Successors");
156
157 type Subp_Info is record
158 Name : Entity_Id := Empty;
159 Next : Subp_Index := No_Subp;
160 First_Succ : Succ_Index := No_Succ;
161 Main_Call : Boolean := False;
162 Processed : Boolean := False;
163 end record;
164
165 package Inlined is new Table.Table (
166 Table_Component_Type => Subp_Info,
167 Table_Index_Type => Subp_Index,
168 Table_Low_Bound => 1,
169 Table_Initial => Alloc.Inlined_Initial,
170 Table_Increment => Alloc.Inlined_Increment,
171 Table_Name => "Inlined");
172
173 -----------------------
174 -- Local Subprograms --
175 -----------------------
176
177 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
178 -- Make two entries in Inlined table, for an inlined subprogram being
179 -- called, and for the inlined subprogram that contains the call. If
180 -- the call is in the main compilation unit, Caller is Empty.
181
182 procedure Add_Inlined_Subprogram (E : Entity_Id);
183 -- Add subprogram E to the list of inlined subprogram for the unit
184
185 function Add_Subp (E : Entity_Id) return Subp_Index;
186 -- Make entry in Inlined table for subprogram E, or return table index
187 -- that already holds E.
188
189 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
190 pragma Inline (Get_Code_Unit_Entity);
191 -- Return the entity node for the unit containing E. Always return the spec
192 -- for a package.
193
194 function Has_Initialized_Type (E : Entity_Id) return Boolean;
195 -- If a candidate for inlining contains type declarations for types with
196 -- nontrivial initialization procedures, they are not worth inlining.
197
198 function Has_Single_Return (N : Node_Id) return Boolean;
199 -- In general we cannot inline functions that return unconstrained type.
200 -- However, we can handle such functions if all return statements return a
201 -- local variable that is the only declaration in the body of the function.
202 -- In that case the call can be replaced by that local variable as is done
203 -- for other inlined calls.
204
205 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
206 -- Return True if E is in the main unit or its spec or in a subunit
207
208 function Is_Nested (E : Entity_Id) return Boolean;
209 -- If the function is nested inside some other function, it will always
210 -- be compiled if that function is, so don't add it to the inline list.
211 -- We cannot compile a nested function outside the scope of the containing
212 -- function anyway. This is also the case if the function is defined in a
213 -- task body or within an entry (for example, an initialization procedure).
214
215 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id);
216 -- Remove all aspects and/or pragmas that have no meaning in inlined body
217 -- Body_Decl. The analysis of these items is performed on the non-inlined
218 -- body. The items currently removed are:
219 -- Contract_Cases
220 -- Global
221 -- Depends
222 -- Postcondition
223 -- Precondition
224 -- Refined_Global
225 -- Refined_Depends
226 -- Refined_Post
227 -- Test_Case
228 -- Unmodified
229 -- Unreferenced
230
231 ------------------------------
232 -- Deferred Cleanup Actions --
233 ------------------------------
234
235 -- The cleanup actions for scopes that contain instantiations is delayed
236 -- until after expansion of those instantiations, because they may contain
237 -- finalizable objects or tasks that affect the cleanup code. A scope
238 -- that contains instantiations only needs to be finalized once, even
239 -- if it contains more than one instance. We keep a list of scopes
240 -- that must still be finalized, and call cleanup_actions after all
241 -- the instantiations have been completed.
242
243 To_Clean : Elist_Id;
244
245 procedure Add_Scope_To_Clean (Inst : Entity_Id);
246 -- Build set of scopes on which cleanup actions must be performed
247
248 procedure Cleanup_Scopes;
249 -- Complete cleanup actions on scopes that need it
250
251 --------------
252 -- Add_Call --
253 --------------
254
255 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
256 P1 : constant Subp_Index := Add_Subp (Called);
257 P2 : Subp_Index;
258 J : Succ_Index;
259
260 begin
261 if Present (Caller) then
262 P2 := Add_Subp (Caller);
263
264 -- Add P1 to the list of successors of P2, if not already there.
265 -- Note that P2 may contain more than one call to P1, and only
266 -- one needs to be recorded.
267
268 J := Inlined.Table (P2).First_Succ;
269 while J /= No_Succ loop
270 if Successors.Table (J).Subp = P1 then
271 return;
272 end if;
273
274 J := Successors.Table (J).Next;
275 end loop;
276
277 -- On exit, make a successor entry for P1
278
279 Successors.Increment_Last;
280 Successors.Table (Successors.Last).Subp := P1;
281 Successors.Table (Successors.Last).Next :=
282 Inlined.Table (P2).First_Succ;
283 Inlined.Table (P2).First_Succ := Successors.Last;
284 else
285 Inlined.Table (P1).Main_Call := True;
286 end if;
287 end Add_Call;
288
289 ----------------------
290 -- Add_Inlined_Body --
291 ----------------------
292
293 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
294
295 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
296 -- Level of inlining for the call: Dont_Inline means no inlining,
297 -- Inline_Call means that only the call is considered for inlining,
298 -- Inline_Package means that the call is considered for inlining and
299 -- its package compiled and scanned for more inlining opportunities.
300
301 function Must_Inline return Inline_Level_Type;
302 -- Inlining is only done if the call statement N is in the main unit,
303 -- or within the body of another inlined subprogram.
304
305 -----------------
306 -- Must_Inline --
307 -----------------
308
309 function Must_Inline return Inline_Level_Type is
310 Scop : Entity_Id;
311 Comp : Node_Id;
312
313 begin
314 -- Check if call is in main unit
315
316 Scop := Current_Scope;
317
318 -- Do not try to inline if scope is standard. This could happen, for
319 -- example, for a call to Add_Global_Declaration, and it causes
320 -- trouble to try to inline at this level.
321
322 if Scop = Standard_Standard then
323 return Dont_Inline;
324 end if;
325
326 -- Otherwise lookup scope stack to outer scope
327
328 while Scope (Scop) /= Standard_Standard
329 and then not Is_Child_Unit (Scop)
330 loop
331 Scop := Scope (Scop);
332 end loop;
333
334 Comp := Parent (Scop);
335 while Nkind (Comp) /= N_Compilation_Unit loop
336 Comp := Parent (Comp);
337 end loop;
338
339 -- If the call is in the main unit, inline the call and compile the
340 -- package of the subprogram to find more calls to be inlined.
341
342 if Comp = Cunit (Main_Unit)
343 or else Comp = Library_Unit (Cunit (Main_Unit))
344 then
345 Add_Call (E);
346 return Inline_Package;
347 end if;
348
349 -- The call is not in the main unit. See if it is in some subprogram
350 -- that can be inlined outside its unit. If so, inline the call and,
351 -- if the inlining level is set to 1, stop there; otherwise also
352 -- compile the package as above.
353
354 Scop := Current_Scope;
355 while Scope (Scop) /= Standard_Standard
356 and then not Is_Child_Unit (Scop)
357 loop
358 if Is_Overloadable (Scop)
359 and then Is_Inlined (Scop)
360 and then not Is_Nested (Scop)
361 then
362 Add_Call (E, Scop);
363
364 if Inline_Level = 1 then
365 return Inline_Call;
366 else
367 return Inline_Package;
368 end if;
369 end if;
370
371 Scop := Scope (Scop);
372 end loop;
373
374 return Dont_Inline;
375 end Must_Inline;
376
377 Level : Inline_Level_Type;
378
379 -- Start of processing for Add_Inlined_Body
380
381 begin
382 Append_New_Elmt (N, To => Backend_Calls);
383
384 -- Skip subprograms that cannot be inlined outside their unit
385
386 if Is_Abstract_Subprogram (E)
387 or else Convention (E) = Convention_Protected
388 or else Is_Nested (E)
389 then
390 return;
391 end if;
392
393 -- Find out whether the call must be inlined. Unless the result is
394 -- Dont_Inline, Must_Inline also creates an edge for the call in the
395 -- callgraph; however, it will not be activated until after Is_Called
396 -- is set on the subprogram.
397
398 Level := Must_Inline;
399
400 if Level = Dont_Inline then
401 return;
402 end if;
403
404 -- If the call was generated by the compiler and is to a subprogram in
405 -- a run-time unit, we need to suppress debugging information for it,
406 -- so that the code that is eventually inlined will not affect the
407 -- debugging of the program. We do not do it if the call comes from
408 -- source because, even if the call is inlined, the user may expect it
409 -- to be present in the debugging information.
410
411 if not Comes_From_Source (N)
412 and then In_Extended_Main_Source_Unit (N)
413 and then
414 Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E)))
415 then
416 Set_Needs_Debug_Info (E, False);
417 end if;
418
419 -- If the subprogram is an expression function, then there is no need to
420 -- load any package body since the body of the function is in the spec.
421
422 if Is_Expression_Function (E) then
423 Set_Is_Called (E);
424 return;
425 end if;
426
427 -- Find unit containing E, and add to list of inlined bodies if needed.
428 -- If the body is already present, no need to load any other unit. This
429 -- is the case for an initialization procedure, which appears in the
430 -- package declaration that contains the type. It is also the case if
431 -- the body has already been analyzed. Finally, if the unit enclosing
432 -- E is an instance, the instance body will be analyzed in any case,
433 -- and there is no need to add the enclosing unit (whose body might not
434 -- be available).
435
436 -- Library-level functions must be handled specially, because there is
437 -- no enclosing package to retrieve. In this case, it is the body of
438 -- the function that will have to be loaded.
439
440 declare
441 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
442
443 begin
444 if Pack = E then
445 Set_Is_Called (E);
446 Inlined_Bodies.Increment_Last;
447 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
448
449 elsif Ekind (Pack) = E_Package then
450 Set_Is_Called (E);
451
452 if Is_Generic_Instance (Pack) then
453 null;
454
455 -- Do not inline the package if the subprogram is an init proc
456 -- or other internally generated subprogram, because in that
457 -- case the subprogram body appears in the same unit that
458 -- declares the type, and that body is visible to the back end.
459 -- Do not inline it either if it is in the main unit.
460 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
461 -- calls if the back-end takes care of inlining the call.
462 -- Note that Level in Inline_Package | Inline_Call here.
463
464 elsif ((Level = Inline_Call
465 and then Has_Pragma_Inline_Always (E)
466 and then Back_End_Inlining)
467 or else Level = Inline_Package)
468 and then not Is_Inlined (Pack)
469 and then not Is_Internal (E)
470 and then not In_Main_Unit_Or_Subunit (Pack)
471 then
472 Set_Is_Inlined (Pack);
473 Inlined_Bodies.Increment_Last;
474 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
475 end if;
476 end if;
477
478 -- Ensure that Analyze_Inlined_Bodies will be invoked after
479 -- completing the analysis of the current unit.
480
481 Inline_Processing_Required := True;
482 end;
483 end Add_Inlined_Body;
484
485 ----------------------------
486 -- Add_Inlined_Subprogram --
487 ----------------------------
488
489 procedure Add_Inlined_Subprogram (E : Entity_Id) is
490 Decl : constant Node_Id := Parent (Declaration_Node (E));
491 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
492
493 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
494 -- Append Subp to the list of subprograms inlined by the backend
495
496 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
497 -- Append Subp to the list of subprograms that cannot be inlined by
498 -- the backend.
499
500 -----------------------------------------
501 -- Register_Backend_Inlined_Subprogram --
502 -----------------------------------------
503
504 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
505 begin
506 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
507 end Register_Backend_Inlined_Subprogram;
508
509 ---------------------------------------------
510 -- Register_Backend_Not_Inlined_Subprogram --
511 ---------------------------------------------
512
513 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
514 begin
515 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
516 end Register_Backend_Not_Inlined_Subprogram;
517
518 -- Start of processing for Add_Inlined_Subprogram
519
520 begin
521 -- If the subprogram is to be inlined, and if its unit is known to be
522 -- inlined or is an instance whose body will be analyzed anyway or the
523 -- subprogram was generated as a body by the compiler (for example an
524 -- initialization procedure) or its declaration was provided along with
525 -- the body (for example an expression function), and if it is declared
526 -- at the library level not in the main unit, and if it can be inlined
527 -- by the back-end, then insert it in the list of inlined subprograms.
528
529 if Is_Inlined (E)
530 and then (Is_Inlined (Pack)
531 or else Is_Generic_Instance (Pack)
532 or else Nkind (Decl) = N_Subprogram_Body
533 or else Present (Corresponding_Body (Decl)))
534 and then not In_Main_Unit_Or_Subunit (E)
535 and then not Is_Nested (E)
536 and then not Has_Initialized_Type (E)
537 then
538 Register_Backend_Inlined_Subprogram (E);
539
540 if No (Last_Inlined) then
541 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
542 else
543 Set_Next_Inlined_Subprogram (Last_Inlined, E);
544 end if;
545
546 Last_Inlined := E;
547
548 else
549 Register_Backend_Not_Inlined_Subprogram (E);
550 end if;
551 end Add_Inlined_Subprogram;
552
553 ------------------------
554 -- Add_Scope_To_Clean --
555 ------------------------
556
557 procedure Add_Scope_To_Clean (Inst : Entity_Id) is
558 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
559 Elmt : Elmt_Id;
560
561 begin
562 -- If the instance appears in a library-level package declaration,
563 -- all finalization is global, and nothing needs doing here.
564
565 if Scop = Standard_Standard then
566 return;
567 end if;
568
569 -- If the instance is within a generic unit, no finalization code
570 -- can be generated. Note that at this point all bodies have been
571 -- analyzed, and the scope stack itself is not present, and the flag
572 -- Inside_A_Generic is not set.
573
574 declare
575 S : Entity_Id;
576
577 begin
578 S := Scope (Inst);
579 while Present (S) and then S /= Standard_Standard loop
580 if Is_Generic_Unit (S) then
581 return;
582 end if;
583
584 S := Scope (S);
585 end loop;
586 end;
587
588 Elmt := First_Elmt (To_Clean);
589 while Present (Elmt) loop
590 if Node (Elmt) = Scop then
591 return;
592 end if;
593
594 Elmt := Next_Elmt (Elmt);
595 end loop;
596
597 Append_Elmt (Scop, To_Clean);
598 end Add_Scope_To_Clean;
599
600 --------------
601 -- Add_Subp --
602 --------------
603
604 function Add_Subp (E : Entity_Id) return Subp_Index is
605 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
606 J : Subp_Index;
607
608 procedure New_Entry;
609 -- Initialize entry in Inlined table
610
611 procedure New_Entry is
612 begin
613 Inlined.Increment_Last;
614 Inlined.Table (Inlined.Last).Name := E;
615 Inlined.Table (Inlined.Last).Next := No_Subp;
616 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
617 Inlined.Table (Inlined.Last).Main_Call := False;
618 Inlined.Table (Inlined.Last).Processed := False;
619 end New_Entry;
620
621 -- Start of processing for Add_Subp
622
623 begin
624 if Hash_Headers (Index) = No_Subp then
625 New_Entry;
626 Hash_Headers (Index) := Inlined.Last;
627 return Inlined.Last;
628
629 else
630 J := Hash_Headers (Index);
631 while J /= No_Subp loop
632 if Inlined.Table (J).Name = E then
633 return J;
634 else
635 Index := J;
636 J := Inlined.Table (J).Next;
637 end if;
638 end loop;
639
640 -- On exit, subprogram was not found. Enter in table. Index is
641 -- the current last entry on the hash chain.
642
643 New_Entry;
644 Inlined.Table (Index).Next := Inlined.Last;
645 return Inlined.Last;
646 end if;
647 end Add_Subp;
648
649 ----------------------------
650 -- Analyze_Inlined_Bodies --
651 ----------------------------
652
653 procedure Analyze_Inlined_Bodies is
654 Comp_Unit : Node_Id;
655 J : Int;
656 Pack : Entity_Id;
657 Subp : Subp_Index;
658 S : Succ_Index;
659
660 type Pending_Index is new Nat;
661
662 package Pending_Inlined is new Table.Table (
663 Table_Component_Type => Subp_Index,
664 Table_Index_Type => Pending_Index,
665 Table_Low_Bound => 1,
666 Table_Initial => Alloc.Inlined_Initial,
667 Table_Increment => Alloc.Inlined_Increment,
668 Table_Name => "Pending_Inlined");
669 -- The workpile used to compute the transitive closure
670
671 function Is_Ancestor_Of_Main
672 (U_Name : Entity_Id;
673 Nam : Node_Id) return Boolean;
674 -- Determine whether the unit whose body is loaded is an ancestor of
675 -- the main unit, and has a with_clause on it. The body is not
676 -- analyzed yet, so the check is purely lexical: the name of the with
677 -- clause is a selected component, and names of ancestors must match.
678
679 -------------------------
680 -- Is_Ancestor_Of_Main --
681 -------------------------
682
683 function Is_Ancestor_Of_Main
684 (U_Name : Entity_Id;
685 Nam : Node_Id) return Boolean
686 is
687 Pref : Node_Id;
688
689 begin
690 if Nkind (Nam) /= N_Selected_Component then
691 return False;
692
693 else
694 if Chars (Selector_Name (Nam)) /=
695 Chars (Cunit_Entity (Main_Unit))
696 then
697 return False;
698 end if;
699
700 Pref := Prefix (Nam);
701 if Nkind (Pref) = N_Identifier then
702
703 -- Par is an ancestor of Par.Child.
704
705 return Chars (Pref) = Chars (U_Name);
706
707 elsif Nkind (Pref) = N_Selected_Component
708 and then Chars (Selector_Name (Pref)) = Chars (U_Name)
709 then
710 -- Par.Child is an ancestor of Par.Child.Grand.
711
712 return True; -- should check that ancestor match
713
714 else
715 -- A is an ancestor of A.B.C if it is an ancestor of A.B
716
717 return Is_Ancestor_Of_Main (U_Name, Pref);
718 end if;
719 end if;
720 end Is_Ancestor_Of_Main;
721
722 -- Start of processing for Analyze_Inlined_Bodies
723
724 begin
725 if Serious_Errors_Detected = 0 then
726 Push_Scope (Standard_Standard);
727
728 J := 0;
729 while J <= Inlined_Bodies.Last
730 and then Serious_Errors_Detected = 0
731 loop
732 Pack := Inlined_Bodies.Table (J);
733 while Present (Pack)
734 and then Scope (Pack) /= Standard_Standard
735 and then not Is_Child_Unit (Pack)
736 loop
737 Pack := Scope (Pack);
738 end loop;
739
740 Comp_Unit := Parent (Pack);
741 while Present (Comp_Unit)
742 and then Nkind (Comp_Unit) /= N_Compilation_Unit
743 loop
744 Comp_Unit := Parent (Comp_Unit);
745 end loop;
746
747 -- Load the body, unless it is the main unit, or is an instance
748 -- whose body has already been analyzed.
749
750 if Present (Comp_Unit)
751 and then Comp_Unit /= Cunit (Main_Unit)
752 and then Body_Required (Comp_Unit)
753 and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
754 or else No (Corresponding_Body (Unit (Comp_Unit))))
755 then
756 declare
757 Bname : constant Unit_Name_Type :=
758 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
759
760 OK : Boolean;
761
762 begin
763 if not Is_Loaded (Bname) then
764 Style_Check := False;
765 Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
766
767 if not OK then
768
769 -- Warn that a body was not available for inlining
770 -- by the back-end.
771
772 Error_Msg_Unit_1 := Bname;
773 Error_Msg_N
774 ("one or more inlined subprograms accessed in $!??",
775 Comp_Unit);
776 Error_Msg_File_1 :=
777 Get_File_Name (Bname, Subunit => False);
778 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
779
780 else
781 -- If the package to be inlined is an ancestor unit of
782 -- the main unit, and it has a semantic dependence on
783 -- it, the inlining cannot take place to prevent an
784 -- elaboration circularity. The desired body is not
785 -- analyzed yet, to prevent the completion of Taft
786 -- amendment types that would lead to elaboration
787 -- circularities in gigi.
788
789 declare
790 U_Id : constant Entity_Id :=
791 Defining_Entity (Unit (Comp_Unit));
792 Body_Unit : constant Node_Id :=
793 Library_Unit (Comp_Unit);
794 Item : Node_Id;
795
796 begin
797 Item := First (Context_Items (Body_Unit));
798 while Present (Item) loop
799 if Nkind (Item) = N_With_Clause
800 and then
801 Is_Ancestor_Of_Main (U_Id, Name (Item))
802 then
803 Set_Is_Inlined (U_Id, False);
804 exit;
805 end if;
806
807 Next (Item);
808 end loop;
809
810 -- If no suspicious with_clauses, analyze the body.
811
812 if Is_Inlined (U_Id) then
813 Semantics (Body_Unit);
814 end if;
815 end;
816 end if;
817 end if;
818 end;
819 end if;
820
821 J := J + 1;
822
823 if J > Inlined_Bodies.Last then
824
825 -- The analysis of required bodies may have produced additional
826 -- generic instantiations. To obtain further inlining, we need
827 -- to perform another round of generic body instantiations.
828
829 Instantiate_Bodies;
830
831 -- Symmetrically, the instantiation of required generic bodies
832 -- may have caused additional bodies to be inlined. To obtain
833 -- further inlining, we keep looping over the inlined bodies.
834 end if;
835 end loop;
836
837 -- The list of inlined subprograms is an overestimate, because it
838 -- includes inlined functions called from functions that are compiled
839 -- as part of an inlined package, but are not themselves called. An
840 -- accurate computation of just those subprograms that are needed
841 -- requires that we perform a transitive closure over the call graph,
842 -- starting from calls in the main compilation unit.
843
844 for Index in Inlined.First .. Inlined.Last loop
845 if not Is_Called (Inlined.Table (Index).Name) then
846
847 -- This means that Add_Inlined_Body added the subprogram to the
848 -- table but wasn't able to handle its code unit. Do nothing.
849
850 Inlined.Table (Index).Processed := True;
851
852 elsif Inlined.Table (Index).Main_Call then
853 Pending_Inlined.Increment_Last;
854 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
855 Inlined.Table (Index).Processed := True;
856
857 else
858 Set_Is_Called (Inlined.Table (Index).Name, False);
859 end if;
860 end loop;
861
862 -- Iterate over the workpile until it is emptied, propagating the
863 -- Is_Called flag to the successors of the processed subprogram.
864
865 while Pending_Inlined.Last >= Pending_Inlined.First loop
866 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
867 Pending_Inlined.Decrement_Last;
868
869 S := Inlined.Table (Subp).First_Succ;
870
871 while S /= No_Succ loop
872 Subp := Successors.Table (S).Subp;
873
874 if not Inlined.Table (Subp).Processed then
875 Set_Is_Called (Inlined.Table (Subp).Name);
876 Pending_Inlined.Increment_Last;
877 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
878 Inlined.Table (Subp).Processed := True;
879 end if;
880
881 S := Successors.Table (S).Next;
882 end loop;
883 end loop;
884
885 -- Finally add the called subprograms to the list of inlined
886 -- subprograms for the unit.
887
888 for Index in Inlined.First .. Inlined.Last loop
889 if Is_Called (Inlined.Table (Index).Name) then
890 Add_Inlined_Subprogram (Inlined.Table (Index).Name);
891 end if;
892 end loop;
893
894 Pop_Scope;
895 end if;
896 end Analyze_Inlined_Bodies;
897
898 --------------------------
899 -- Build_Body_To_Inline --
900 --------------------------
901
902 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
903 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
904 Analysis_Status : constant Boolean := Full_Analysis;
905 Original_Body : Node_Id;
906 Body_To_Analyze : Node_Id;
907 Max_Size : constant := 10;
908
909 function Has_Pending_Instantiation return Boolean;
910 -- If some enclosing body contains instantiations that appear before
911 -- the corresponding generic body, the enclosing body has a freeze node
912 -- so that it can be elaborated after the generic itself. This might
913 -- conflict with subsequent inlinings, so that it is unsafe to try to
914 -- inline in such a case.
915
916 function Has_Single_Return_In_GNATprove_Mode return Boolean;
917 -- This function is called only in GNATprove mode, and it returns
918 -- True if the subprogram has no return statement or a single return
919 -- statement as last statement. It returns False for subprogram with
920 -- a single return as last statement inside one or more blocks, as
921 -- inlining would generate gotos in that case as well (although the
922 -- goto is useless in that case).
923
924 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
925 -- If the body of the subprogram includes a call that returns an
926 -- unconstrained type, the secondary stack is involved, and it
927 -- is not worth inlining.
928
929 -------------------------------
930 -- Has_Pending_Instantiation --
931 -------------------------------
932
933 function Has_Pending_Instantiation return Boolean is
934 S : Entity_Id;
935
936 begin
937 S := Current_Scope;
938 while Present (S) loop
939 if Is_Compilation_Unit (S)
940 or else Is_Child_Unit (S)
941 then
942 return False;
943
944 elsif Ekind (S) = E_Package
945 and then Has_Forward_Instantiation (S)
946 then
947 return True;
948 end if;
949
950 S := Scope (S);
951 end loop;
952
953 return False;
954 end Has_Pending_Instantiation;
955
956 -----------------------------------------
957 -- Has_Single_Return_In_GNATprove_Mode --
958 -----------------------------------------
959
960 function Has_Single_Return_In_GNATprove_Mode return Boolean is
961 Last_Statement : Node_Id := Empty;
962
963 function Check_Return (N : Node_Id) return Traverse_Result;
964 -- Returns OK on node N if this is not a return statement different
965 -- from the last statement in the subprogram.
966
967 ------------------
968 -- Check_Return --
969 ------------------
970
971 function Check_Return (N : Node_Id) return Traverse_Result is
972 begin
973 if Nkind_In (N, N_Simple_Return_Statement,
974 N_Extended_Return_Statement)
975 then
976 if N = Last_Statement then
977 return OK;
978 else
979 return Abandon;
980 end if;
981
982 else
983 return OK;
984 end if;
985 end Check_Return;
986
987 function Check_All_Returns is new Traverse_Func (Check_Return);
988
989 -- Start of processing for Has_Single_Return_In_GNATprove_Mode
990
991 begin
992 -- Retrieve the last statement
993
994 Last_Statement := Last (Statements (Handled_Statement_Sequence (N)));
995
996 -- Check that the last statement is the only possible return
997 -- statement in the subprogram.
998
999 return Check_All_Returns (N) = OK;
1000 end Has_Single_Return_In_GNATprove_Mode;
1001
1002 --------------------------
1003 -- Uses_Secondary_Stack --
1004 --------------------------
1005
1006 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1007 function Check_Call (N : Node_Id) return Traverse_Result;
1008 -- Look for function calls that return an unconstrained type
1009
1010 ----------------
1011 -- Check_Call --
1012 ----------------
1013
1014 function Check_Call (N : Node_Id) return Traverse_Result is
1015 begin
1016 if Nkind (N) = N_Function_Call
1017 and then Is_Entity_Name (Name (N))
1018 and then Is_Composite_Type (Etype (Entity (Name (N))))
1019 and then not Is_Constrained (Etype (Entity (Name (N))))
1020 then
1021 Cannot_Inline
1022 ("cannot inline & (call returns unconstrained type)?",
1023 N, Spec_Id);
1024 return Abandon;
1025 else
1026 return OK;
1027 end if;
1028 end Check_Call;
1029
1030 function Check_Calls is new Traverse_Func (Check_Call);
1031
1032 begin
1033 return Check_Calls (Bod) = Abandon;
1034 end Uses_Secondary_Stack;
1035
1036 -- Start of processing for Build_Body_To_Inline
1037
1038 begin
1039 -- Return immediately if done already
1040
1041 if Nkind (Decl) = N_Subprogram_Declaration
1042 and then Present (Body_To_Inline (Decl))
1043 then
1044 return;
1045
1046 -- Subprograms that have return statements in the middle of the body are
1047 -- inlined with gotos. GNATprove does not currently support gotos, so
1048 -- we prevent such inlining.
1049
1050 elsif GNATprove_Mode
1051 and then not Has_Single_Return_In_GNATprove_Mode
1052 then
1053 Cannot_Inline ("cannot inline & (multiple returns)?", N, Spec_Id);
1054 return;
1055
1056 -- Functions that return unconstrained composite types require
1057 -- secondary stack handling, and cannot currently be inlined, unless
1058 -- all return statements return a local variable that is the first
1059 -- local declaration in the body.
1060
1061 elsif Ekind (Spec_Id) = E_Function
1062 and then not Is_Scalar_Type (Etype (Spec_Id))
1063 and then not Is_Access_Type (Etype (Spec_Id))
1064 and then not Is_Constrained (Etype (Spec_Id))
1065 then
1066 if not Has_Single_Return (N) then
1067 Cannot_Inline
1068 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1069 return;
1070 end if;
1071
1072 -- Ditto for functions that return controlled types, where controlled
1073 -- actions interfere in complex ways with inlining.
1074
1075 elsif Ekind (Spec_Id) = E_Function
1076 and then Needs_Finalization (Etype (Spec_Id))
1077 then
1078 Cannot_Inline
1079 ("cannot inline & (controlled return type)?", N, Spec_Id);
1080 return;
1081 end if;
1082
1083 if Present (Declarations (N))
1084 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
1085 then
1086 return;
1087 end if;
1088
1089 if Present (Handled_Statement_Sequence (N)) then
1090 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1091 Cannot_Inline
1092 ("cannot inline& (exception handler)?",
1093 First (Exception_Handlers (Handled_Statement_Sequence (N))),
1094 Spec_Id);
1095 return;
1096
1097 elsif Has_Excluded_Statement
1098 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
1099 then
1100 return;
1101 end if;
1102 end if;
1103
1104 -- We do not inline a subprogram that is too large, unless it is marked
1105 -- Inline_Always or we are in GNATprove mode. This pragma does not
1106 -- suppress the other checks on inlining (forbidden declarations,
1107 -- handlers, etc).
1108
1109 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1110 and then List_Length
1111 (Statements (Handled_Statement_Sequence (N))) > Max_Size
1112 then
1113 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
1114 return;
1115 end if;
1116
1117 if Has_Pending_Instantiation then
1118 Cannot_Inline
1119 ("cannot inline& (forward instance within enclosing body)?",
1120 N, Spec_Id);
1121 return;
1122 end if;
1123
1124 -- Within an instance, the body to inline must be treated as a nested
1125 -- generic, so that the proper global references are preserved.
1126
1127 -- Note that we do not do this at the library level, because it is not
1128 -- needed, and furthermore this causes trouble if front end inlining
1129 -- is activated (-gnatN).
1130
1131 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1132 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1133 Original_Body := Copy_Generic_Node (N, Empty, True);
1134 else
1135 Original_Body := Copy_Separate_Tree (N);
1136 end if;
1137
1138 -- We need to capture references to the formals in order to substitute
1139 -- the actuals at the point of inlining, i.e. instantiation. To treat
1140 -- the formals as globals to the body to inline, we nest it within a
1141 -- dummy parameterless subprogram, declared within the real one. To
1142 -- avoid generating an internal name (which is never public, and which
1143 -- affects serial numbers of other generated names), we use an internal
1144 -- symbol that cannot conflict with user declarations.
1145
1146 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1147 Set_Defining_Unit_Name
1148 (Specification (Original_Body),
1149 Make_Defining_Identifier (Sloc (N), Name_uParent));
1150 Set_Corresponding_Spec (Original_Body, Empty);
1151
1152 -- Remove all aspects/pragmas that have no meaining in an inlined body
1153
1154 Remove_Aspects_And_Pragmas (Original_Body);
1155
1156 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1157
1158 -- Set return type of function, which is also global and does not need
1159 -- to be resolved.
1160
1161 if Ekind (Spec_Id) = E_Function then
1162 Set_Result_Definition
1163 (Specification (Body_To_Analyze),
1164 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1165 end if;
1166
1167 if No (Declarations (N)) then
1168 Set_Declarations (N, New_List (Body_To_Analyze));
1169 else
1170 Append (Body_To_Analyze, Declarations (N));
1171 end if;
1172
1173 -- The body to inline is pre-analyzed. In GNATprove mode we must disable
1174 -- full analysis as well so that light expansion does not take place
1175 -- either, and name resolution is unaffected.
1176
1177 Expander_Mode_Save_And_Set (False);
1178 Full_Analysis := False;
1179
1180 Analyze (Body_To_Analyze);
1181 Push_Scope (Defining_Entity (Body_To_Analyze));
1182 Save_Global_References (Original_Body);
1183 End_Scope;
1184 Remove (Body_To_Analyze);
1185
1186 Expander_Mode_Restore;
1187 Full_Analysis := Analysis_Status;
1188
1189 -- Restore environment if previously saved
1190
1191 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1192 Restore_Env;
1193 end if;
1194
1195 -- If secondary stack is used, there is no point in inlining. We have
1196 -- already issued the warning in this case, so nothing to do.
1197
1198 if Uses_Secondary_Stack (Body_To_Analyze) then
1199 return;
1200 end if;
1201
1202 Set_Body_To_Inline (Decl, Original_Body);
1203 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1204 Set_Is_Inlined (Spec_Id);
1205 end Build_Body_To_Inline;
1206
1207 -------------------
1208 -- Cannot_Inline --
1209 -------------------
1210
1211 procedure Cannot_Inline
1212 (Msg : String;
1213 N : Node_Id;
1214 Subp : Entity_Id;
1215 Is_Serious : Boolean := False)
1216 is
1217 begin
1218 -- In GNATprove mode, inlining is the technical means by which the
1219 -- higher-level goal of contextual analysis is reached, so issue
1220 -- messages about failure to apply contextual analysis to a
1221 -- subprogram, rather than failure to inline it.
1222
1223 if GNATprove_Mode
1224 and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
1225 then
1226 declare
1227 Len1 : constant Positive :=
1228 String (String'("cannot inline"))'Length;
1229 Len2 : constant Positive :=
1230 String (String'("info: no contextual analysis of"))'Length;
1231
1232 New_Msg : String (1 .. Msg'Length + Len2 - Len1);
1233
1234 begin
1235 New_Msg (1 .. Len2) := "info: no contextual analysis of";
1236 New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
1237 Msg (Msg'First + Len1 .. Msg'Last);
1238 Cannot_Inline (New_Msg, N, Subp, Is_Serious);
1239 return;
1240 end;
1241 end if;
1242
1243 pragma Assert (Msg (Msg'Last) = '?');
1244
1245 -- Legacy front end inlining model
1246
1247 if not Back_End_Inlining then
1248
1249 -- Do not emit warning if this is a predefined unit which is not
1250 -- the main unit. With validity checks enabled, some predefined
1251 -- subprograms may contain nested subprograms and become ineligible
1252 -- for inlining.
1253
1254 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1255 and then not In_Extended_Main_Source_Unit (Subp)
1256 then
1257 null;
1258
1259 -- In GNATprove mode, issue a warning, and indicate that the
1260 -- subprogram is not always inlined by setting flag Is_Inlined_Always
1261 -- to False.
1262
1263 elsif GNATprove_Mode then
1264 Set_Is_Inlined_Always (Subp, False);
1265 Error_Msg_NE (Msg & "p?", N, Subp);
1266
1267 elsif Has_Pragma_Inline_Always (Subp) then
1268
1269 -- Remove last character (question mark) to make this into an
1270 -- error, because the Inline_Always pragma cannot be obeyed.
1271
1272 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1273
1274 elsif Ineffective_Inline_Warnings then
1275 Error_Msg_NE (Msg & "p?", N, Subp);
1276 end if;
1277
1278 -- New semantics relying on back end inlining
1279
1280 elsif Is_Serious then
1281
1282 -- Remove last character (question mark) to make this into an error.
1283
1284 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1285
1286 -- In GNATprove mode, issue a warning, and indicate that the subprogram
1287 -- is not always inlined by setting flag Is_Inlined_Always to False.
1288
1289 elsif GNATprove_Mode then
1290 Set_Is_Inlined_Always (Subp, False);
1291 Error_Msg_NE (Msg & "p?", N, Subp);
1292
1293 else
1294
1295 -- Do not emit warning if this is a predefined unit which is not
1296 -- the main unit. This behavior is currently provided for backward
1297 -- compatibility but it will be removed when we enforce the
1298 -- strictness of the new rules.
1299
1300 if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
1301 and then not In_Extended_Main_Source_Unit (Subp)
1302 then
1303 null;
1304
1305 elsif Has_Pragma_Inline_Always (Subp) then
1306
1307 -- Emit a warning if this is a call to a runtime subprogram
1308 -- which is located inside a generic. Previously this call
1309 -- was silently skipped.
1310
1311 if Is_Generic_Instance (Subp) then
1312 declare
1313 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
1314 begin
1315 if Is_Predefined_File_Name
1316 (Unit_File_Name (Get_Source_Unit (Gen_P)))
1317 then
1318 Set_Is_Inlined (Subp, False);
1319 Error_Msg_NE (Msg & "p?", N, Subp);
1320 return;
1321 end if;
1322 end;
1323 end if;
1324
1325 -- Remove last character (question mark) to make this into an
1326 -- error, because the Inline_Always pragma cannot be obeyed.
1327
1328 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
1329
1330 else
1331 Set_Is_Inlined (Subp, False);
1332
1333 if Ineffective_Inline_Warnings then
1334 Error_Msg_NE (Msg & "p?", N, Subp);
1335 end if;
1336 end if;
1337 end if;
1338 end Cannot_Inline;
1339
1340 --------------------------------------
1341 -- Can_Be_Inlined_In_GNATprove_Mode --
1342 --------------------------------------
1343
1344 function Can_Be_Inlined_In_GNATprove_Mode
1345 (Spec_Id : Entity_Id;
1346 Body_Id : Entity_Id) return Boolean
1347 is
1348 function Has_Formal_With_Discriminant_Dependent_Fields
1349 (Id : Entity_Id) return Boolean;
1350 -- Returns true if the subprogram has at least one formal parameter of
1351 -- an unconstrained record type with per-object constraints on component
1352 -- types.
1353
1354 function Has_Some_Contract (Id : Entity_Id) return Boolean;
1355 -- Returns True if subprogram Id has any contract (Pre, Post, Global,
1356 -- Depends, etc.)
1357
1358 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
1359 -- Returns True if subprogram Id defines a compilation unit
1360 -- Shouldn't this be in Sem_Aux???
1361
1362 function In_Package_Visible_Spec (Id : Node_Id) return Boolean;
1363 -- Returns True if subprogram Id is defined in the visible part of a
1364 -- package specification.
1365
1366 ---------------------------------------------------
1367 -- Has_Formal_With_Discriminant_Dependent_Fields --
1368 ---------------------------------------------------
1369
1370 function Has_Formal_With_Discriminant_Dependent_Fields
1371 (Id : Entity_Id) return Boolean is
1372
1373 function Has_Discriminant_Dependent_Component
1374 (Typ : Entity_Id) return Boolean;
1375 -- Determine whether unconstrained record type Typ has at least
1376 -- one component that depends on a discriminant.
1377
1378 ------------------------------------------
1379 -- Has_Discriminant_Dependent_Component --
1380 ------------------------------------------
1381
1382 function Has_Discriminant_Dependent_Component
1383 (Typ : Entity_Id) return Boolean
1384 is
1385 Comp : Entity_Id;
1386
1387 begin
1388 -- Inspect all components of the record type looking for one
1389 -- that depends on a discriminant.
1390
1391 Comp := First_Component (Typ);
1392 while Present (Comp) loop
1393 if Has_Discriminant_Dependent_Constraint (Comp) then
1394 return True;
1395 end if;
1396
1397 Next_Component (Comp);
1398 end loop;
1399
1400 return False;
1401 end Has_Discriminant_Dependent_Component;
1402
1403 -- Local variables
1404
1405 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1406 Formal : Entity_Id;
1407 Formal_Typ : Entity_Id;
1408
1409 -- Start of processing for
1410 -- Has_Formal_With_Discriminant_Dependent_Component
1411
1412 begin
1413 -- Inspect all parameters of the subprogram looking for a formal
1414 -- of an unconstrained record type with at least one discriminant
1415 -- dependent component.
1416
1417 Formal := First_Formal (Subp_Id);
1418 while Present (Formal) loop
1419 Formal_Typ := Etype (Formal);
1420
1421 if Is_Record_Type (Formal_Typ)
1422 and then not Is_Constrained (Formal_Typ)
1423 and then Has_Discriminant_Dependent_Component (Formal_Typ)
1424 then
1425 return True;
1426 end if;
1427
1428 Next_Formal (Formal);
1429 end loop;
1430
1431 return False;
1432 end Has_Formal_With_Discriminant_Dependent_Fields;
1433
1434 -----------------------
1435 -- Has_Some_Contract --
1436 -----------------------
1437
1438 function Has_Some_Contract (Id : Entity_Id) return Boolean is
1439 Items : Node_Id;
1440
1441 begin
1442 -- A call to an expression function may precede the actual body which
1443 -- is inserted at the end of the enclosing declarations. Ensure that
1444 -- the related entity is decorated before inspecting the contract.
1445
1446 if Is_Subprogram_Or_Generic_Subprogram (Id) then
1447 Items := Contract (Id);
1448
1449 return Present (Items)
1450 and then (Present (Pre_Post_Conditions (Items)) or else
1451 Present (Contract_Test_Cases (Items)) or else
1452 Present (Classifications (Items)));
1453 end if;
1454
1455 return False;
1456 end Has_Some_Contract;
1457
1458 -----------------------------
1459 -- In_Package_Visible_Spec --
1460 -----------------------------
1461
1462 function In_Package_Visible_Spec (Id : Node_Id) return Boolean is
1463 Decl : Node_Id := Parent (Parent (Id));
1464 P : Node_Id;
1465
1466 begin
1467 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1468 Decl := Parent (Decl);
1469 end if;
1470
1471 P := Parent (Decl);
1472
1473 return Nkind (P) = N_Package_Specification
1474 and then List_Containing (Decl) = Visible_Declarations (P);
1475 end In_Package_Visible_Spec;
1476
1477 ------------------------
1478 -- Is_Unit_Subprogram --
1479 ------------------------
1480
1481 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1482 Decl : Node_Id := Parent (Parent (Id));
1483 begin
1484 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1485 Decl := Parent (Decl);
1486 end if;
1487
1488 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1489 end Is_Unit_Subprogram;
1490
1491 -- Local declarations
1492
1493 Id : Entity_Id; -- Procedure or function entity for the subprogram
1494
1495 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
1496
1497 begin
1498 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1499
1500 if Present (Spec_Id) then
1501 Id := Spec_Id;
1502 else
1503 Id := Body_Id;
1504 end if;
1505
1506 -- Only local subprograms without contracts are inlined in GNATprove
1507 -- mode, as these are the subprograms which a user is not interested in
1508 -- analyzing in isolation, but rather in the context of their call. This
1509 -- is a convenient convention, that could be changed for an explicit
1510 -- pragma/aspect one day.
1511
1512 -- In a number of special cases, inlining is not desirable or not
1513 -- possible, see below.
1514
1515 -- Do not inline unit-level subprograms
1516
1517 if Is_Unit_Subprogram (Id) then
1518 return False;
1519
1520 -- Do not inline subprograms declared in the visible part of a package
1521
1522 elsif In_Package_Visible_Spec (Id) then
1523 return False;
1524
1525 -- Do not inline subprograms marked No_Return, possibly used for
1526 -- signaling errors, which GNATprove handles specially.
1527
1528 elsif No_Return (Id) then
1529 return False;
1530
1531 -- Do not inline subprograms that have a contract on the spec or the
1532 -- body. Use the contract(s) instead in GNATprove.
1533
1534 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
1535 or else
1536 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
1537 then
1538 return False;
1539
1540 -- Do not inline expression functions, which are directly inlined at the
1541 -- prover level.
1542
1543 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
1544 or else
1545 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
1546 then
1547 return False;
1548
1549 -- Do not inline generic subprogram instances. The visibility rules of
1550 -- generic instances plays badly with inlining.
1551
1552 elsif Is_Generic_Instance (Spec_Id) then
1553 return False;
1554
1555 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
1556 -- the subprogram body, a similar check is performed after the body
1557 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
1558
1559 elsif Present (Spec_Id)
1560 and then
1561 (No (SPARK_Pragma (Spec_Id))
1562 or else
1563 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
1564 then
1565 return False;
1566
1567 -- Subprograms in generic instances are currently not inlined, to avoid
1568 -- problems with inlining of standard library subprograms.
1569
1570 elsif Instantiation_Location (Sloc (Id)) /= No_Location then
1571 return False;
1572
1573 -- Do not inline predicate functions (treated specially by GNATprove)
1574
1575 elsif Is_Predicate_Function (Id) then
1576 return False;
1577
1578 -- Do not inline subprograms with a parameter of an unconstrained
1579 -- record type if it has discrimiant dependent fields. Indeed, with
1580 -- such parameters, the frontend cannot always ensure type compliance
1581 -- in record component accesses (in particular with records containing
1582 -- packed arrays).
1583
1584 elsif Has_Formal_With_Discriminant_Dependent_Fields (Id) then
1585 return False;
1586
1587 -- Otherwise, this is a subprogram declared inside the private part of a
1588 -- package, or inside a package body, or locally in a subprogram, and it
1589 -- does not have any contract. Inline it.
1590
1591 else
1592 return True;
1593 end if;
1594 end Can_Be_Inlined_In_GNATprove_Mode;
1595
1596 --------------------------------------------
1597 -- Check_And_Split_Unconstrained_Function --
1598 --------------------------------------------
1599
1600 procedure Check_And_Split_Unconstrained_Function
1601 (N : Node_Id;
1602 Spec_Id : Entity_Id;
1603 Body_Id : Entity_Id)
1604 is
1605 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
1606 -- Use generic machinery to build an unexpanded body for the subprogram.
1607 -- This body is subsequently used for inline expansions at call sites.
1608
1609 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
1610 -- Return true if we generate code for the function body N, the function
1611 -- body N has no local declarations and its unique statement is a single
1612 -- extended return statement with a handled statements sequence.
1613
1614 procedure Generate_Subprogram_Body
1615 (N : Node_Id;
1616 Body_To_Inline : out Node_Id);
1617 -- Generate a parameterless duplicate of subprogram body N. Occurrences
1618 -- of pragmas referencing the formals are removed since they have no
1619 -- meaning when the body is inlined and the formals are rewritten (the
1620 -- analysis of the non-inlined body will handle these pragmas properly).
1621 -- A new internal name is associated with Body_To_Inline.
1622
1623 procedure Split_Unconstrained_Function
1624 (N : Node_Id;
1625 Spec_Id : Entity_Id);
1626 -- N is an inlined function body that returns an unconstrained type and
1627 -- has a single extended return statement. Split N in two subprograms:
1628 -- a procedure P' and a function F'. The formals of P' duplicate the
1629 -- formals of N plus an extra formal which is used return a value;
1630 -- its body is composed by the declarations and list of statements
1631 -- of the extended return statement of N.
1632
1633 --------------------------
1634 -- Build_Body_To_Inline --
1635 --------------------------
1636
1637 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1638 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1639 Original_Body : Node_Id;
1640 Body_To_Analyze : Node_Id;
1641
1642 begin
1643 pragma Assert (Current_Scope = Spec_Id);
1644
1645 -- Within an instance, the body to inline must be treated as a nested
1646 -- generic, so that the proper global references are preserved. We
1647 -- do not do this at the library level, because it is not needed, and
1648 -- furthermore this causes trouble if front end inlining is activated
1649 -- (-gnatN).
1650
1651 if In_Instance
1652 and then Scope (Current_Scope) /= Standard_Standard
1653 then
1654 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
1655 end if;
1656
1657 -- We need to capture references to the formals in order
1658 -- to substitute the actuals at the point of inlining, i.e.
1659 -- instantiation. To treat the formals as globals to the body to
1660 -- inline, we nest it within a dummy parameterless subprogram,
1661 -- declared within the real one.
1662
1663 Generate_Subprogram_Body (N, Original_Body);
1664 Body_To_Analyze := Copy_Generic_Node (Original_Body, Empty, False);
1665
1666 -- Set return type of function, which is also global and does not
1667 -- need to be resolved.
1668
1669 if Ekind (Spec_Id) = E_Function then
1670 Set_Result_Definition (Specification (Body_To_Analyze),
1671 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
1672 end if;
1673
1674 if No (Declarations (N)) then
1675 Set_Declarations (N, New_List (Body_To_Analyze));
1676 else
1677 Append_To (Declarations (N), Body_To_Analyze);
1678 end if;
1679
1680 Preanalyze (Body_To_Analyze);
1681
1682 Push_Scope (Defining_Entity (Body_To_Analyze));
1683 Save_Global_References (Original_Body);
1684 End_Scope;
1685 Remove (Body_To_Analyze);
1686
1687 -- Restore environment if previously saved
1688
1689 if In_Instance
1690 and then Scope (Current_Scope) /= Standard_Standard
1691 then
1692 Restore_Env;
1693 end if;
1694
1695 pragma Assert (No (Body_To_Inline (Decl)));
1696 Set_Body_To_Inline (Decl, Original_Body);
1697 Set_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
1698 end Build_Body_To_Inline;
1699
1700 --------------------------------------
1701 -- Can_Split_Unconstrained_Function --
1702 --------------------------------------
1703
1704 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean
1705 is
1706 Ret_Node : constant Node_Id :=
1707 First (Statements (Handled_Statement_Sequence (N)));
1708 D : Node_Id;
1709
1710 begin
1711 -- No user defined declarations allowed in the function except inside
1712 -- the unique return statement; implicit labels are the only allowed
1713 -- declarations.
1714
1715 if not Is_Empty_List (Declarations (N)) then
1716 D := First (Declarations (N));
1717 while Present (D) loop
1718 if Nkind (D) /= N_Implicit_Label_Declaration then
1719 return False;
1720 end if;
1721
1722 Next (D);
1723 end loop;
1724 end if;
1725
1726 -- We only split the inlined function when we are generating the code
1727 -- of its body; otherwise we leave duplicated split subprograms in
1728 -- the tree which (if referenced) generate wrong references at link
1729 -- time.
1730
1731 return In_Extended_Main_Code_Unit (N)
1732 and then Present (Ret_Node)
1733 and then Nkind (Ret_Node) = N_Extended_Return_Statement
1734 and then No (Next (Ret_Node))
1735 and then Present (Handled_Statement_Sequence (Ret_Node));
1736 end Can_Split_Unconstrained_Function;
1737
1738 -----------------------------
1739 -- Generate_Body_To_Inline --
1740 -----------------------------
1741
1742 procedure Generate_Subprogram_Body
1743 (N : Node_Id;
1744 Body_To_Inline : out Node_Id)
1745 is
1746 begin
1747 -- Within an instance, the body to inline must be treated as a nested
1748 -- generic, so that the proper global references are preserved.
1749
1750 -- Note that we do not do this at the library level, because it
1751 -- is not needed, and furthermore this causes trouble if front
1752 -- end inlining is activated (-gnatN).
1753
1754 if In_Instance
1755 and then Scope (Current_Scope) /= Standard_Standard
1756 then
1757 Body_To_Inline := Copy_Generic_Node (N, Empty, True);
1758 else
1759 Body_To_Inline := Copy_Separate_Tree (N);
1760 end if;
1761
1762 -- Remove all aspects/pragmas that have no meaning in an inlined body
1763
1764 Remove_Aspects_And_Pragmas (Body_To_Inline);
1765
1766 -- We need to capture references to the formals in order
1767 -- to substitute the actuals at the point of inlining, i.e.
1768 -- instantiation. To treat the formals as globals to the body to
1769 -- inline, we nest it within a dummy parameterless subprogram,
1770 -- declared within the real one.
1771
1772 Set_Parameter_Specifications
1773 (Specification (Body_To_Inline), No_List);
1774
1775 -- A new internal name is associated with Body_To_Inline to avoid
1776 -- conflicts when the non-inlined body N is analyzed.
1777
1778 Set_Defining_Unit_Name (Specification (Body_To_Inline),
1779 Make_Defining_Identifier (Sloc (N), New_Internal_Name ('P')));
1780 Set_Corresponding_Spec (Body_To_Inline, Empty);
1781 end Generate_Subprogram_Body;
1782
1783 ----------------------------------
1784 -- Split_Unconstrained_Function --
1785 ----------------------------------
1786
1787 procedure Split_Unconstrained_Function
1788 (N : Node_Id;
1789 Spec_Id : Entity_Id)
1790 is
1791 Loc : constant Source_Ptr := Sloc (N);
1792 Ret_Node : constant Node_Id :=
1793 First (Statements (Handled_Statement_Sequence (N)));
1794 Ret_Obj : constant Node_Id :=
1795 First (Return_Object_Declarations (Ret_Node));
1796
1797 procedure Build_Procedure
1798 (Proc_Id : out Entity_Id;
1799 Decl_List : out List_Id);
1800 -- Build a procedure containing the statements found in the extended
1801 -- return statement of the unconstrained function body N.
1802
1803 ---------------------
1804 -- Build_Procedure --
1805 ---------------------
1806
1807 procedure Build_Procedure
1808 (Proc_Id : out Entity_Id;
1809 Decl_List : out List_Id)
1810 is
1811 Formal : Entity_Id;
1812 Formal_List : constant List_Id := New_List;
1813 Proc_Spec : Node_Id;
1814 Proc_Body : Node_Id;
1815 Subp_Name : constant Name_Id := New_Internal_Name ('F');
1816 Body_Decl_List : List_Id := No_List;
1817 Param_Type : Node_Id;
1818
1819 begin
1820 if Nkind (Object_Definition (Ret_Obj)) = N_Identifier then
1821 Param_Type :=
1822 New_Copy (Object_Definition (Ret_Obj));
1823 else
1824 Param_Type :=
1825 New_Copy (Subtype_Mark (Object_Definition (Ret_Obj)));
1826 end if;
1827
1828 Append_To (Formal_List,
1829 Make_Parameter_Specification (Loc,
1830 Defining_Identifier =>
1831 Make_Defining_Identifier (Loc,
1832 Chars => Chars (Defining_Identifier (Ret_Obj))),
1833 In_Present => False,
1834 Out_Present => True,
1835 Null_Exclusion_Present => False,
1836 Parameter_Type => Param_Type));
1837
1838 Formal := First_Formal (Spec_Id);
1839
1840 -- Note that we copy the parameter type rather than creating
1841 -- a reference to it, because it may be a class-wide entity
1842 -- that will not be retrieved by name.
1843
1844 while Present (Formal) loop
1845 Append_To (Formal_List,
1846 Make_Parameter_Specification (Loc,
1847 Defining_Identifier =>
1848 Make_Defining_Identifier (Sloc (Formal),
1849 Chars => Chars (Formal)),
1850 In_Present => In_Present (Parent (Formal)),
1851 Out_Present => Out_Present (Parent (Formal)),
1852 Null_Exclusion_Present =>
1853 Null_Exclusion_Present (Parent (Formal)),
1854 Parameter_Type =>
1855 New_Copy_Tree (Parameter_Type (Parent (Formal))),
1856 Expression =>
1857 Copy_Separate_Tree (Expression (Parent (Formal)))));
1858
1859 Next_Formal (Formal);
1860 end loop;
1861
1862 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
1863
1864 Proc_Spec :=
1865 Make_Procedure_Specification (Loc,
1866 Defining_Unit_Name => Proc_Id,
1867 Parameter_Specifications => Formal_List);
1868
1869 Decl_List := New_List;
1870
1871 Append_To (Decl_List,
1872 Make_Subprogram_Declaration (Loc, Proc_Spec));
1873
1874 -- Can_Convert_Unconstrained_Function checked that the function
1875 -- has no local declarations except implicit label declarations.
1876 -- Copy these declarations to the built procedure.
1877
1878 if Present (Declarations (N)) then
1879 Body_Decl_List := New_List;
1880
1881 declare
1882 D : Node_Id;
1883 New_D : Node_Id;
1884
1885 begin
1886 D := First (Declarations (N));
1887 while Present (D) loop
1888 pragma Assert (Nkind (D) = N_Implicit_Label_Declaration);
1889
1890 New_D :=
1891 Make_Implicit_Label_Declaration (Loc,
1892 Make_Defining_Identifier (Loc,
1893 Chars => Chars (Defining_Identifier (D))),
1894 Label_Construct => Empty);
1895 Append_To (Body_Decl_List, New_D);
1896
1897 Next (D);
1898 end loop;
1899 end;
1900 end if;
1901
1902 pragma Assert (Present (Handled_Statement_Sequence (Ret_Node)));
1903
1904 Proc_Body :=
1905 Make_Subprogram_Body (Loc,
1906 Specification => Copy_Separate_Tree (Proc_Spec),
1907 Declarations => Body_Decl_List,
1908 Handled_Statement_Sequence =>
1909 Copy_Separate_Tree (Handled_Statement_Sequence (Ret_Node)));
1910
1911 Set_Defining_Unit_Name (Specification (Proc_Body),
1912 Make_Defining_Identifier (Loc, Subp_Name));
1913
1914 Append_To (Decl_List, Proc_Body);
1915 end Build_Procedure;
1916
1917 -- Local variables
1918
1919 New_Obj : constant Node_Id := Copy_Separate_Tree (Ret_Obj);
1920 Blk_Stmt : Node_Id;
1921 Proc_Id : Entity_Id;
1922 Proc_Call : Node_Id;
1923
1924 -- Start of processing for Split_Unconstrained_Function
1925
1926 begin
1927 -- Build the associated procedure, analyze it and insert it before
1928 -- the function body N.
1929
1930 declare
1931 Scope : constant Entity_Id := Current_Scope;
1932 Decl_List : List_Id;
1933 begin
1934 Pop_Scope;
1935 Build_Procedure (Proc_Id, Decl_List);
1936 Insert_Actions (N, Decl_List);
1937 Push_Scope (Scope);
1938 end;
1939
1940 -- Build the call to the generated procedure
1941
1942 declare
1943 Actual_List : constant List_Id := New_List;
1944 Formal : Entity_Id;
1945
1946 begin
1947 Append_To (Actual_List,
1948 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
1949
1950 Formal := First_Formal (Spec_Id);
1951 while Present (Formal) loop
1952 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
1953
1954 -- Avoid spurious warning on unreferenced formals
1955
1956 Set_Referenced (Formal);
1957 Next_Formal (Formal);
1958 end loop;
1959
1960 Proc_Call :=
1961 Make_Procedure_Call_Statement (Loc,
1962 Name => New_Occurrence_Of (Proc_Id, Loc),
1963 Parameter_Associations => Actual_List);
1964 end;
1965
1966 -- Generate
1967
1968 -- declare
1969 -- New_Obj : ...
1970 -- begin
1971 -- main_1__F1b (New_Obj, ...);
1972 -- return Obj;
1973 -- end B10b;
1974
1975 Blk_Stmt :=
1976 Make_Block_Statement (Loc,
1977 Declarations => New_List (New_Obj),
1978 Handled_Statement_Sequence =>
1979 Make_Handled_Sequence_Of_Statements (Loc,
1980 Statements => New_List (
1981
1982 Proc_Call,
1983
1984 Make_Simple_Return_Statement (Loc,
1985 Expression =>
1986 New_Occurrence_Of
1987 (Defining_Identifier (New_Obj), Loc)))));
1988
1989 Rewrite (Ret_Node, Blk_Stmt);
1990 end Split_Unconstrained_Function;
1991
1992 -- Local variables
1993
1994 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
1995
1996 -- Start of processing for Check_And_Split_Unconstrained_Function
1997
1998 begin
1999 pragma Assert (Back_End_Inlining
2000 and then Ekind (Spec_Id) = E_Function
2001 and then Returns_Unconstrained_Type (Spec_Id)
2002 and then Comes_From_Source (Body_Id)
2003 and then (Has_Pragma_Inline_Always (Spec_Id)
2004 or else Optimization_Level > 0));
2005
2006 -- This routine must not be used in GNATprove mode since GNATprove
2007 -- relies on frontend inlining
2008
2009 pragma Assert (not GNATprove_Mode);
2010
2011 -- No need to split the function if we cannot generate the code
2012
2013 if Serious_Errors_Detected /= 0 then
2014 return;
2015 end if;
2016
2017 -- No action needed in stubs since the attribute Body_To_Inline
2018 -- is not available
2019
2020 if Nkind (Decl) = N_Subprogram_Body_Stub then
2021 return;
2022
2023 -- Cannot build the body to inline if the attribute is already set.
2024 -- This attribute may have been set if this is a subprogram renaming
2025 -- declarations (see Freeze.Build_Renamed_Body).
2026
2027 elsif Present (Body_To_Inline (Decl)) then
2028 return;
2029
2030 -- Check excluded declarations
2031
2032 elsif Present (Declarations (N))
2033 and then Has_Excluded_Declaration (Spec_Id, Declarations (N))
2034 then
2035 return;
2036
2037 -- Check excluded statements. There is no need to protect us against
2038 -- exception handlers since they are supported by the GCC backend.
2039
2040 elsif Present (Handled_Statement_Sequence (N))
2041 and then Has_Excluded_Statement
2042 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2043 then
2044 return;
2045 end if;
2046
2047 -- Build the body to inline only if really needed
2048
2049 if Can_Split_Unconstrained_Function (N) then
2050 Split_Unconstrained_Function (N, Spec_Id);
2051 Build_Body_To_Inline (N, Spec_Id);
2052 Set_Is_Inlined (Spec_Id);
2053 end if;
2054 end Check_And_Split_Unconstrained_Function;
2055
2056 -------------------------------------
2057 -- Check_Package_Body_For_Inlining --
2058 -------------------------------------
2059
2060 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
2061 Bname : Unit_Name_Type;
2062 E : Entity_Id;
2063 OK : Boolean;
2064
2065 begin
2066 -- Legacy implementation (relying on frontend inlining)
2067
2068 if not Back_End_Inlining
2069 and then Is_Compilation_Unit (P)
2070 and then not Is_Generic_Instance (P)
2071 then
2072 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2073
2074 E := First_Entity (P);
2075 while Present (E) loop
2076 if Has_Pragma_Inline_Always (E)
2077 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2078 then
2079 if not Is_Loaded (Bname) then
2080 Load_Needed_Body (N, OK);
2081
2082 if OK then
2083
2084 -- Check we are not trying to inline a parent whose body
2085 -- depends on a child, when we are compiling the body of
2086 -- the child. Otherwise we have a potential elaboration
2087 -- circularity with inlined subprograms and with
2088 -- Taft-Amendment types.
2089
2090 declare
2091 Comp : Node_Id; -- Body just compiled
2092 Child_Spec : Entity_Id; -- Spec of main unit
2093 Ent : Entity_Id; -- For iteration
2094 With_Clause : Node_Id; -- Context of body.
2095
2096 begin
2097 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2098 and then Present (Body_Entity (P))
2099 then
2100 Child_Spec :=
2101 Defining_Entity
2102 ((Unit (Library_Unit (Cunit (Main_Unit)))));
2103
2104 Comp :=
2105 Parent (Unit_Declaration_Node (Body_Entity (P)));
2106
2107 -- Check whether the context of the body just
2108 -- compiled includes a child of itself, and that
2109 -- child is the spec of the main compilation.
2110
2111 With_Clause := First (Context_Items (Comp));
2112 while Present (With_Clause) loop
2113 if Nkind (With_Clause) = N_With_Clause
2114 and then
2115 Scope (Entity (Name (With_Clause))) = P
2116 and then
2117 Entity (Name (With_Clause)) = Child_Spec
2118 then
2119 Error_Msg_Node_2 := Child_Spec;
2120 Error_Msg_NE
2121 ("body of & depends on child unit&??",
2122 With_Clause, P);
2123 Error_Msg_N
2124 ("\subprograms in body cannot be inlined??",
2125 With_Clause);
2126
2127 -- Disable further inlining from this unit,
2128 -- and keep Taft-amendment types incomplete.
2129
2130 Ent := First_Entity (P);
2131 while Present (Ent) loop
2132 if Is_Type (Ent)
2133 and then Has_Completion_In_Body (Ent)
2134 then
2135 Set_Full_View (Ent, Empty);
2136
2137 elsif Is_Subprogram (Ent) then
2138 Set_Is_Inlined (Ent, False);
2139 end if;
2140
2141 Next_Entity (Ent);
2142 end loop;
2143
2144 return;
2145 end if;
2146
2147 Next (With_Clause);
2148 end loop;
2149 end if;
2150 end;
2151
2152 elsif Ineffective_Inline_Warnings then
2153 Error_Msg_Unit_1 := Bname;
2154 Error_Msg_N
2155 ("unable to inline subprograms defined in $??", P);
2156 Error_Msg_N ("\body not found??", P);
2157 return;
2158 end if;
2159 end if;
2160
2161 return;
2162 end if;
2163
2164 Next_Entity (E);
2165 end loop;
2166 end if;
2167 end Check_Package_Body_For_Inlining;
2168
2169 --------------------
2170 -- Cleanup_Scopes --
2171 --------------------
2172
2173 procedure Cleanup_Scopes is
2174 Elmt : Elmt_Id;
2175 Decl : Node_Id;
2176 Scop : Entity_Id;
2177
2178 begin
2179 Elmt := First_Elmt (To_Clean);
2180 while Present (Elmt) loop
2181 Scop := Node (Elmt);
2182
2183 if Ekind (Scop) = E_Entry then
2184 Scop := Protected_Body_Subprogram (Scop);
2185
2186 elsif Is_Subprogram (Scop)
2187 and then Is_Protected_Type (Scope (Scop))
2188 and then Present (Protected_Body_Subprogram (Scop))
2189 then
2190 -- If a protected operation contains an instance, its cleanup
2191 -- operations have been delayed, and the subprogram has been
2192 -- rewritten in the expansion of the enclosing protected body. It
2193 -- is the corresponding subprogram that may require the cleanup
2194 -- operations, so propagate the information that triggers cleanup
2195 -- activity.
2196
2197 Set_Uses_Sec_Stack
2198 (Protected_Body_Subprogram (Scop),
2199 Uses_Sec_Stack (Scop));
2200
2201 Scop := Protected_Body_Subprogram (Scop);
2202 end if;
2203
2204 if Ekind (Scop) = E_Block then
2205 Decl := Parent (Block_Node (Scop));
2206
2207 else
2208 Decl := Unit_Declaration_Node (Scop);
2209
2210 if Nkind_In (Decl, N_Subprogram_Declaration,
2211 N_Task_Type_Declaration,
2212 N_Subprogram_Body_Stub)
2213 then
2214 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2215 end if;
2216 end if;
2217
2218 Push_Scope (Scop);
2219 Expand_Cleanup_Actions (Decl);
2220 End_Scope;
2221
2222 Elmt := Next_Elmt (Elmt);
2223 end loop;
2224 end Cleanup_Scopes;
2225
2226 -------------------------
2227 -- Expand_Inlined_Call --
2228 -------------------------
2229
2230 procedure Expand_Inlined_Call
2231 (N : Node_Id;
2232 Subp : Entity_Id;
2233 Orig_Subp : Entity_Id)
2234 is
2235 Loc : constant Source_Ptr := Sloc (N);
2236 Is_Predef : constant Boolean :=
2237 Is_Predefined_File_Name
2238 (Unit_File_Name (Get_Source_Unit (Subp)));
2239 Orig_Bod : constant Node_Id :=
2240 Body_To_Inline (Unit_Declaration_Node (Subp));
2241
2242 Blk : Node_Id;
2243 Decl : Node_Id;
2244 Decls : constant List_Id := New_List;
2245 Exit_Lab : Entity_Id := Empty;
2246 F : Entity_Id;
2247 A : Node_Id;
2248 Lab_Decl : Node_Id;
2249 Lab_Id : Node_Id;
2250 New_A : Node_Id;
2251 Num_Ret : Nat := 0;
2252 Ret_Type : Entity_Id;
2253
2254 Targ : Node_Id;
2255 -- The target of the call. If context is an assignment statement then
2256 -- this is the left-hand side of the assignment, else it is a temporary
2257 -- to which the return value is assigned prior to rewriting the call.
2258
2259 Targ1 : Node_Id;
2260 -- A separate target used when the return type is unconstrained
2261
2262 Temp : Entity_Id;
2263 Temp_Typ : Entity_Id;
2264
2265 Return_Object : Entity_Id := Empty;
2266 -- Entity in declaration in an extended_return_statement
2267
2268 Is_Unc : Boolean;
2269 Is_Unc_Decl : Boolean;
2270 -- If the type returned by the function is unconstrained and the call
2271 -- can be inlined, special processing is required.
2272
2273 procedure Declare_Postconditions_Result;
2274 -- When generating C code, declare _Result, which may be used in the
2275 -- inlined _Postconditions procedure to verify the return value.
2276
2277 procedure Make_Exit_Label;
2278 -- Build declaration for exit label to be used in Return statements,
2279 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
2280 -- declaration). Does nothing if Exit_Lab already set.
2281
2282 function Process_Formals (N : Node_Id) return Traverse_Result;
2283 -- Replace occurrence of a formal with the corresponding actual, or the
2284 -- thunk generated for it. Replace a return statement with an assignment
2285 -- to the target of the call, with appropriate conversions if needed.
2286
2287 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
2288 -- If the call being expanded is that of an internal subprogram, set the
2289 -- sloc of the generated block to that of the call itself, so that the
2290 -- expansion is skipped by the "next" command in gdb. Same processing
2291 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
2292 -- Debug_Generated_Code is true, suppress this change to simplify our
2293 -- own development. Same in GNATprove mode, to ensure that warnings and
2294 -- diagnostics point to the proper location.
2295
2296 procedure Reset_Dispatching_Calls (N : Node_Id);
2297 -- In subtree N search for occurrences of dispatching calls that use the
2298 -- Ada 2005 Object.Operation notation and the object is a formal of the
2299 -- inlined subprogram. Reset the entity associated with Operation in all
2300 -- the found occurrences.
2301
2302 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
2303 -- If the function body is a single expression, replace call with
2304 -- expression, else insert block appropriately.
2305
2306 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id);
2307 -- If procedure body has no local variables, inline body without
2308 -- creating block, otherwise rewrite call with block.
2309
2310 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
2311 -- Determine whether a formal parameter is used only once in Orig_Bod
2312
2313 -----------------------------------
2314 -- Declare_Postconditions_Result --
2315 -----------------------------------
2316
2317 procedure Declare_Postconditions_Result is
2318 Enclosing_Subp : constant Entity_Id := Scope (Subp);
2319
2320 begin
2321 pragma Assert
2322 (Modify_Tree_For_C
2323 and then Is_Subprogram (Enclosing_Subp)
2324 and then Present (Postconditions_Proc (Enclosing_Subp)));
2325
2326 if Ekind (Enclosing_Subp) = E_Function then
2327 if Nkind (First (Parameter_Associations (N))) in
2328 N_Numeric_Or_String_Literal
2329 then
2330 Append_To (Declarations (Blk),
2331 Make_Object_Declaration (Loc,
2332 Defining_Identifier =>
2333 Make_Defining_Identifier (Loc, Name_uResult),
2334 Constant_Present => True,
2335 Object_Definition =>
2336 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2337 Expression =>
2338 New_Copy_Tree (First (Parameter_Associations (N)))));
2339 else
2340 Append_To (Declarations (Blk),
2341 Make_Object_Renaming_Declaration (Loc,
2342 Defining_Identifier =>
2343 Make_Defining_Identifier (Loc, Name_uResult),
2344 Subtype_Mark =>
2345 New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
2346 Name =>
2347 New_Copy_Tree (First (Parameter_Associations (N)))));
2348 end if;
2349 end if;
2350 end Declare_Postconditions_Result;
2351
2352 ---------------------
2353 -- Make_Exit_Label --
2354 ---------------------
2355
2356 procedure Make_Exit_Label is
2357 Lab_Ent : Entity_Id;
2358 begin
2359 if No (Exit_Lab) then
2360 Lab_Ent := Make_Temporary (Loc, 'L');
2361 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
2362 Exit_Lab := Make_Label (Loc, Lab_Id);
2363 Lab_Decl :=
2364 Make_Implicit_Label_Declaration (Loc,
2365 Defining_Identifier => Lab_Ent,
2366 Label_Construct => Exit_Lab);
2367 end if;
2368 end Make_Exit_Label;
2369
2370 ---------------------
2371 -- Process_Formals --
2372 ---------------------
2373
2374 function Process_Formals (N : Node_Id) return Traverse_Result is
2375 A : Entity_Id;
2376 E : Entity_Id;
2377 Ret : Node_Id;
2378
2379 begin
2380 if Is_Entity_Name (N) and then Present (Entity (N)) then
2381 E := Entity (N);
2382
2383 if Is_Formal (E) and then Scope (E) = Subp then
2384 A := Renamed_Object (E);
2385
2386 -- Rewrite the occurrence of the formal into an occurrence of
2387 -- the actual. Also establish visibility on the proper view of
2388 -- the actual's subtype for the body's context (if the actual's
2389 -- subtype is private at the call point but its full view is
2390 -- visible to the body, then the inlined tree here must be
2391 -- analyzed with the full view).
2392
2393 if Is_Entity_Name (A) then
2394 Rewrite (N, New_Occurrence_Of (Entity (A), Sloc (N)));
2395 Check_Private_View (N);
2396
2397 elsif Nkind (A) = N_Defining_Identifier then
2398 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
2399 Check_Private_View (N);
2400
2401 -- Numeric literal
2402
2403 else
2404 Rewrite (N, New_Copy (A));
2405 end if;
2406 end if;
2407
2408 return Skip;
2409
2410 elsif Is_Entity_Name (N)
2411 and then Present (Return_Object)
2412 and then Chars (N) = Chars (Return_Object)
2413 then
2414 -- Occurrence within an extended return statement. The return
2415 -- object is local to the body been inlined, and thus the generic
2416 -- copy is not analyzed yet, so we match by name, and replace it
2417 -- with target of call.
2418
2419 if Nkind (Targ) = N_Defining_Identifier then
2420 Rewrite (N, New_Occurrence_Of (Targ, Loc));
2421 else
2422 Rewrite (N, New_Copy_Tree (Targ));
2423 end if;
2424
2425 return Skip;
2426
2427 elsif Nkind (N) = N_Simple_Return_Statement then
2428 if No (Expression (N)) then
2429 Make_Exit_Label;
2430 Rewrite (N,
2431 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2432
2433 else
2434 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
2435 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
2436 then
2437 -- Function body is a single expression. No need for
2438 -- exit label.
2439
2440 null;
2441
2442 else
2443 Num_Ret := Num_Ret + 1;
2444 Make_Exit_Label;
2445 end if;
2446
2447 -- Because of the presence of private types, the views of the
2448 -- expression and the context may be different, so place an
2449 -- unchecked conversion to the context type to avoid spurious
2450 -- errors, e.g. when the expression is a numeric literal and
2451 -- the context is private. If the expression is an aggregate,
2452 -- use a qualified expression, because an aggregate is not a
2453 -- legal argument of a conversion. Ditto for numeric literals,
2454 -- which must be resolved to a specific type.
2455
2456 if Nkind_In (Expression (N), N_Aggregate,
2457 N_Null,
2458 N_Real_Literal,
2459 N_Integer_Literal)
2460 then
2461 Ret :=
2462 Make_Qualified_Expression (Sloc (N),
2463 Subtype_Mark => New_Occurrence_Of (Ret_Type, Sloc (N)),
2464 Expression => Relocate_Node (Expression (N)));
2465 else
2466 Ret :=
2467 Unchecked_Convert_To
2468 (Ret_Type, Relocate_Node (Expression (N)));
2469 end if;
2470
2471 if Nkind (Targ) = N_Defining_Identifier then
2472 Rewrite (N,
2473 Make_Assignment_Statement (Loc,
2474 Name => New_Occurrence_Of (Targ, Loc),
2475 Expression => Ret));
2476 else
2477 Rewrite (N,
2478 Make_Assignment_Statement (Loc,
2479 Name => New_Copy (Targ),
2480 Expression => Ret));
2481 end if;
2482
2483 Set_Assignment_OK (Name (N));
2484
2485 if Present (Exit_Lab) then
2486 Insert_After (N,
2487 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
2488 end if;
2489 end if;
2490
2491 return OK;
2492
2493 -- An extended return becomes a block whose first statement is the
2494 -- assignment of the initial expression of the return object to the
2495 -- target of the call itself.
2496
2497 elsif Nkind (N) = N_Extended_Return_Statement then
2498 declare
2499 Return_Decl : constant Entity_Id :=
2500 First (Return_Object_Declarations (N));
2501 Assign : Node_Id;
2502
2503 begin
2504 Return_Object := Defining_Identifier (Return_Decl);
2505
2506 if Present (Expression (Return_Decl)) then
2507 if Nkind (Targ) = N_Defining_Identifier then
2508 Assign :=
2509 Make_Assignment_Statement (Loc,
2510 Name => New_Occurrence_Of (Targ, Loc),
2511 Expression => Expression (Return_Decl));
2512 else
2513 Assign :=
2514 Make_Assignment_Statement (Loc,
2515 Name => New_Copy (Targ),
2516 Expression => Expression (Return_Decl));
2517 end if;
2518
2519 Set_Assignment_OK (Name (Assign));
2520
2521 if No (Handled_Statement_Sequence (N)) then
2522 Set_Handled_Statement_Sequence (N,
2523 Make_Handled_Sequence_Of_Statements (Loc,
2524 Statements => New_List));
2525 end if;
2526
2527 Prepend (Assign,
2528 Statements (Handled_Statement_Sequence (N)));
2529 end if;
2530
2531 Rewrite (N,
2532 Make_Block_Statement (Loc,
2533 Handled_Statement_Sequence =>
2534 Handled_Statement_Sequence (N)));
2535
2536 return OK;
2537 end;
2538
2539 -- Remove pragma Unreferenced since it may refer to formals that
2540 -- are not visible in the inlined body, and in any case we will
2541 -- not be posting warnings on the inlined body so it is unneeded.
2542
2543 elsif Nkind (N) = N_Pragma
2544 and then Pragma_Name (N) = Name_Unreferenced
2545 then
2546 Rewrite (N, Make_Null_Statement (Sloc (N)));
2547 return OK;
2548
2549 else
2550 return OK;
2551 end if;
2552 end Process_Formals;
2553
2554 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
2555
2556 ------------------
2557 -- Process_Sloc --
2558 ------------------
2559
2560 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
2561 begin
2562 if not Debug_Generated_Code then
2563 Set_Sloc (Nod, Sloc (N));
2564 Set_Comes_From_Source (Nod, False);
2565 end if;
2566
2567 return OK;
2568 end Process_Sloc;
2569
2570 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
2571
2572 ------------------------------
2573 -- Reset_Dispatching_Calls --
2574 ------------------------------
2575
2576 procedure Reset_Dispatching_Calls (N : Node_Id) is
2577
2578 function Do_Reset (N : Node_Id) return Traverse_Result;
2579 -- Comment required ???
2580
2581 --------------
2582 -- Do_Reset --
2583 --------------
2584
2585 function Do_Reset (N : Node_Id) return Traverse_Result is
2586 begin
2587 if Nkind (N) = N_Procedure_Call_Statement
2588 and then Nkind (Name (N)) = N_Selected_Component
2589 and then Nkind (Prefix (Name (N))) = N_Identifier
2590 and then Is_Formal (Entity (Prefix (Name (N))))
2591 and then Is_Dispatching_Operation
2592 (Entity (Selector_Name (Name (N))))
2593 then
2594 Set_Entity (Selector_Name (Name (N)), Empty);
2595 end if;
2596
2597 return OK;
2598 end Do_Reset;
2599
2600 function Do_Reset_Calls is new Traverse_Func (Do_Reset);
2601
2602 -- Local variables
2603
2604 Dummy : constant Traverse_Result := Do_Reset_Calls (N);
2605 pragma Unreferenced (Dummy);
2606
2607 -- Start of processing for Reset_Dispatching_Calls
2608
2609 begin
2610 null;
2611 end Reset_Dispatching_Calls;
2612
2613 ---------------------------
2614 -- Rewrite_Function_Call --
2615 ---------------------------
2616
2617 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
2618 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2619 Fst : constant Node_Id := First (Statements (HSS));
2620
2621 begin
2622 -- Optimize simple case: function body is a single return statement,
2623 -- which has been expanded into an assignment.
2624
2625 if Is_Empty_List (Declarations (Blk))
2626 and then Nkind (Fst) = N_Assignment_Statement
2627 and then No (Next (Fst))
2628 then
2629 -- The function call may have been rewritten as the temporary
2630 -- that holds the result of the call, in which case remove the
2631 -- now useless declaration.
2632
2633 if Nkind (N) = N_Identifier
2634 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2635 then
2636 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
2637 end if;
2638
2639 Rewrite (N, Expression (Fst));
2640
2641 elsif Nkind (N) = N_Identifier
2642 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
2643 then
2644 -- The block assigns the result of the call to the temporary
2645
2646 Insert_After (Parent (Entity (N)), Blk);
2647
2648 -- If the context is an assignment, and the left-hand side is free of
2649 -- side-effects, the replacement is also safe.
2650 -- Can this be generalized further???
2651
2652 elsif Nkind (Parent (N)) = N_Assignment_Statement
2653 and then
2654 (Is_Entity_Name (Name (Parent (N)))
2655 or else
2656 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
2657 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
2658
2659 or else
2660 (Nkind (Name (Parent (N))) = N_Selected_Component
2661 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
2662 then
2663 -- Replace assignment with the block
2664
2665 declare
2666 Original_Assignment : constant Node_Id := Parent (N);
2667
2668 begin
2669 -- Preserve the original assignment node to keep the complete
2670 -- assignment subtree consistent enough for Analyze_Assignment
2671 -- to proceed (specifically, the original Lhs node must still
2672 -- have an assignment statement as its parent).
2673
2674 -- We cannot rely on Original_Node to go back from the block
2675 -- node to the assignment node, because the assignment might
2676 -- already be a rewrite substitution.
2677
2678 Discard_Node (Relocate_Node (Original_Assignment));
2679 Rewrite (Original_Assignment, Blk);
2680 end;
2681
2682 elsif Nkind (Parent (N)) = N_Object_Declaration then
2683
2684 -- A call to a function which returns an unconstrained type
2685 -- found in the expression initializing an object-declaration is
2686 -- expanded into a procedure call which must be added after the
2687 -- object declaration.
2688
2689 if Is_Unc_Decl and Back_End_Inlining then
2690 Insert_Action_After (Parent (N), Blk);
2691 else
2692 Set_Expression (Parent (N), Empty);
2693 Insert_After (Parent (N), Blk);
2694 end if;
2695
2696 elsif Is_Unc and then not Back_End_Inlining then
2697 Insert_Before (Parent (N), Blk);
2698 end if;
2699 end Rewrite_Function_Call;
2700
2701 ----------------------------
2702 -- Rewrite_Procedure_Call --
2703 ----------------------------
2704
2705 procedure Rewrite_Procedure_Call (N : Node_Id; Blk : Node_Id) is
2706 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
2707
2708 begin
2709 -- If there is a transient scope for N, this will be the scope of the
2710 -- actions for N, and the statements in Blk need to be within this
2711 -- scope. For example, they need to have visibility on the constant
2712 -- declarations created for the formals.
2713
2714 -- If N needs no transient scope, and if there are no declarations in
2715 -- the inlined body, we can do a little optimization and insert the
2716 -- statements for the body directly after N, and rewrite N to a
2717 -- null statement, instead of rewriting N into a full-blown block
2718 -- statement.
2719
2720 if not Scope_Is_Transient
2721 and then Is_Empty_List (Declarations (Blk))
2722 then
2723 Insert_List_After (N, Statements (HSS));
2724 Rewrite (N, Make_Null_Statement (Loc));
2725 else
2726 Rewrite (N, Blk);
2727 end if;
2728 end Rewrite_Procedure_Call;
2729
2730 -------------------------
2731 -- Formal_Is_Used_Once --
2732 -------------------------
2733
2734 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
2735 Use_Counter : Int := 0;
2736
2737 function Count_Uses (N : Node_Id) return Traverse_Result;
2738 -- Traverse the tree and count the uses of the formal parameter.
2739 -- In this case, for optimization purposes, we do not need to
2740 -- continue the traversal once more than one use is encountered.
2741
2742 ----------------
2743 -- Count_Uses --
2744 ----------------
2745
2746 function Count_Uses (N : Node_Id) return Traverse_Result is
2747 begin
2748 -- The original node is an identifier
2749
2750 if Nkind (N) = N_Identifier
2751 and then Present (Entity (N))
2752
2753 -- Original node's entity points to the one in the copied body
2754
2755 and then Nkind (Entity (N)) = N_Identifier
2756 and then Present (Entity (Entity (N)))
2757
2758 -- The entity of the copied node is the formal parameter
2759
2760 and then Entity (Entity (N)) = Formal
2761 then
2762 Use_Counter := Use_Counter + 1;
2763
2764 if Use_Counter > 1 then
2765
2766 -- Denote more than one use and abandon the traversal
2767
2768 Use_Counter := 2;
2769 return Abandon;
2770
2771 end if;
2772 end if;
2773
2774 return OK;
2775 end Count_Uses;
2776
2777 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
2778
2779 -- Start of processing for Formal_Is_Used_Once
2780
2781 begin
2782 Count_Formal_Uses (Orig_Bod);
2783 return Use_Counter = 1;
2784 end Formal_Is_Used_Once;
2785
2786 -- Start of processing for Expand_Inlined_Call
2787
2788 begin
2789 -- Initializations for old/new semantics
2790
2791 if not Back_End_Inlining then
2792 Is_Unc := Is_Array_Type (Etype (Subp))
2793 and then not Is_Constrained (Etype (Subp));
2794 Is_Unc_Decl := False;
2795 else
2796 Is_Unc := Returns_Unconstrained_Type (Subp)
2797 and then Optimization_Level > 0;
2798 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
2799 and then Is_Unc;
2800 end if;
2801
2802 -- Check for an illegal attempt to inline a recursive procedure. If the
2803 -- subprogram has parameters this is detected when trying to supply a
2804 -- binding for parameters that already have one. For parameterless
2805 -- subprograms this must be done explicitly.
2806
2807 if In_Open_Scopes (Subp) then
2808 Cannot_Inline
2809 ("cannot inline call to recursive subprogram?", N, Subp);
2810 Set_Is_Inlined (Subp, False);
2811 return;
2812
2813 -- Skip inlining if this is not a true inlining since the attribute
2814 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
2815 -- true inlining, Orig_Bod has code rather than being an entity.
2816
2817 elsif Nkind (Orig_Bod) in N_Entity then
2818 return;
2819
2820 -- Skip inlining if the function returns an unconstrained type using
2821 -- an extended return statement since this part of the new inlining
2822 -- model which is not yet supported by the current implementation. ???
2823
2824 elsif Is_Unc
2825 and then
2826 Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2827 N_Extended_Return_Statement
2828 and then not Back_End_Inlining
2829 then
2830 return;
2831 end if;
2832
2833 if Nkind (Orig_Bod) = N_Defining_Identifier
2834 or else Nkind (Orig_Bod) = N_Defining_Operator_Symbol
2835 then
2836 -- Subprogram is renaming_as_body. Calls occurring after the renaming
2837 -- can be replaced with calls to the renamed entity directly, because
2838 -- the subprograms are subtype conformant. If the renamed subprogram
2839 -- is an inherited operation, we must redo the expansion because
2840 -- implicit conversions may be needed. Similarly, if the renamed
2841 -- entity is inlined, expand the call for further optimizations.
2842
2843 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
2844
2845 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
2846 Expand_Call (N);
2847 end if;
2848
2849 return;
2850 end if;
2851
2852 -- Register the call in the list of inlined calls
2853
2854 Append_New_Elmt (N, To => Inlined_Calls);
2855
2856 -- Use generic machinery to copy body of inlined subprogram, as if it
2857 -- were an instantiation, resetting source locations appropriately, so
2858 -- that nested inlined calls appear in the main unit.
2859
2860 Save_Env (Subp, Empty);
2861 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
2862
2863 -- Old semantics
2864
2865 if not Back_End_Inlining then
2866 declare
2867 Bod : Node_Id;
2868
2869 begin
2870 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2871 Blk :=
2872 Make_Block_Statement (Loc,
2873 Declarations => Declarations (Bod),
2874 Handled_Statement_Sequence =>
2875 Handled_Statement_Sequence (Bod));
2876
2877 if No (Declarations (Bod)) then
2878 Set_Declarations (Blk, New_List);
2879 end if;
2880
2881 -- When generating C code, declare _Result, which may be used to
2882 -- verify the return value.
2883
2884 if Modify_Tree_For_C
2885 and then Nkind (N) = N_Procedure_Call_Statement
2886 and then Chars (Name (N)) = Name_uPostconditions
2887 then
2888 Declare_Postconditions_Result;
2889 end if;
2890
2891 -- For the unconstrained case, capture the name of the local
2892 -- variable that holds the result. This must be the first
2893 -- declaration in the block, because its bounds cannot depend
2894 -- on local variables. Otherwise there is no way to declare the
2895 -- result outside of the block. Needless to say, in general the
2896 -- bounds will depend on the actuals in the call.
2897
2898 -- If the context is an assignment statement, as is the case
2899 -- for the expansion of an extended return, the left-hand side
2900 -- provides bounds even if the return type is unconstrained.
2901
2902 if Is_Unc then
2903 declare
2904 First_Decl : Node_Id;
2905
2906 begin
2907 First_Decl := First (Declarations (Blk));
2908
2909 if Nkind (First_Decl) /= N_Object_Declaration then
2910 return;
2911 end if;
2912
2913 if Nkind (Parent (N)) /= N_Assignment_Statement then
2914 Targ1 := Defining_Identifier (First_Decl);
2915 else
2916 Targ1 := Name (Parent (N));
2917 end if;
2918 end;
2919 end if;
2920 end;
2921
2922 -- New semantics
2923
2924 else
2925 declare
2926 Bod : Node_Id;
2927
2928 begin
2929 -- General case
2930
2931 if not Is_Unc then
2932 Bod :=
2933 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
2934 Blk :=
2935 Make_Block_Statement (Loc,
2936 Declarations => Declarations (Bod),
2937 Handled_Statement_Sequence =>
2938 Handled_Statement_Sequence (Bod));
2939
2940 -- Inline a call to a function that returns an unconstrained type.
2941 -- The semantic analyzer checked that frontend-inlined functions
2942 -- returning unconstrained types have no declarations and have
2943 -- a single extended return statement. As part of its processing
2944 -- the function was split in two subprograms: a procedure P and
2945 -- a function F that has a block with a call to procedure P (see
2946 -- Split_Unconstrained_Function).
2947
2948 else
2949 pragma Assert
2950 (Nkind
2951 (First
2952 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
2953 N_Block_Statement);
2954
2955 declare
2956 Blk_Stmt : constant Node_Id :=
2957 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
2958 First_Stmt : constant Node_Id :=
2959 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
2960 Second_Stmt : constant Node_Id := Next (First_Stmt);
2961
2962 begin
2963 pragma Assert
2964 (Nkind (First_Stmt) = N_Procedure_Call_Statement
2965 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
2966 and then No (Next (Second_Stmt)));
2967
2968 Bod :=
2969 Copy_Generic_Node
2970 (First
2971 (Statements (Handled_Statement_Sequence (Orig_Bod))),
2972 Empty, Instantiating => True);
2973 Blk := Bod;
2974
2975 -- Capture the name of the local variable that holds the
2976 -- result. This must be the first declaration in the block,
2977 -- because its bounds cannot depend on local variables.
2978 -- Otherwise there is no way to declare the result outside
2979 -- of the block. Needless to say, in general the bounds will
2980 -- depend on the actuals in the call.
2981
2982 if Nkind (Parent (N)) /= N_Assignment_Statement then
2983 Targ1 := Defining_Identifier (First (Declarations (Blk)));
2984
2985 -- If the context is an assignment statement, as is the case
2986 -- for the expansion of an extended return, the left-hand
2987 -- side provides bounds even if the return type is
2988 -- unconstrained.
2989
2990 else
2991 Targ1 := Name (Parent (N));
2992 end if;
2993 end;
2994 end if;
2995
2996 if No (Declarations (Bod)) then
2997 Set_Declarations (Blk, New_List);
2998 end if;
2999 end;
3000 end if;
3001
3002 -- If this is a derived function, establish the proper return type
3003
3004 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3005 Ret_Type := Etype (Orig_Subp);
3006 else
3007 Ret_Type := Etype (Subp);
3008 end if;
3009
3010 -- Create temporaries for the actuals that are expressions, or that are
3011 -- scalars and require copying to preserve semantics.
3012
3013 F := First_Formal (Subp);
3014 A := First_Actual (N);
3015 while Present (F) loop
3016 if Present (Renamed_Object (F)) then
3017
3018 -- If expander is active, it is an error to try to inline a
3019 -- recursive program. In GNATprove mode, just indicate that the
3020 -- inlining will not happen, and mark the subprogram as not always
3021 -- inlined.
3022
3023 if GNATprove_Mode then
3024 Cannot_Inline
3025 ("cannot inline call to recursive subprogram?", N, Subp);
3026 Set_Is_Inlined_Always (Subp, False);
3027 else
3028 Error_Msg_N
3029 ("cannot inline call to recursive subprogram", N);
3030 end if;
3031
3032 return;
3033 end if;
3034
3035 -- Reset Last_Assignment for any parameters of mode out or in out, to
3036 -- prevent spurious warnings about overwriting for assignments to the
3037 -- formal in the inlined code.
3038
3039 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
3040 Set_Last_Assignment (Entity (A), Empty);
3041 end if;
3042
3043 -- If the argument may be a controlling argument in a call within
3044 -- the inlined body, we must preserve its classwide nature to insure
3045 -- that dynamic dispatching take place subsequently. If the formal
3046 -- has a constraint it must be preserved to retain the semantics of
3047 -- the body.
3048
3049 if Is_Class_Wide_Type (Etype (F))
3050 or else (Is_Access_Type (Etype (F))
3051 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3052 then
3053 Temp_Typ := Etype (F);
3054
3055 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3056 and then Etype (F) /= Base_Type (Etype (F))
3057 then
3058 Temp_Typ := Etype (F);
3059 else
3060 Temp_Typ := Etype (A);
3061 end if;
3062
3063 -- If the actual is a simple name or a literal, no need to
3064 -- create a temporary, object can be used directly.
3065
3066 -- If the actual is a literal and the formal has its address taken,
3067 -- we cannot pass the literal itself as an argument, so its value
3068 -- must be captured in a temporary.
3069
3070 if (Is_Entity_Name (A)
3071 and then
3072 (not Is_Scalar_Type (Etype (A))
3073 or else Ekind (Entity (A)) = E_Enumeration_Literal))
3074
3075 -- When the actual is an identifier and the corresponding formal is
3076 -- used only once in the original body, the formal can be substituted
3077 -- directly with the actual parameter.
3078
3079 or else (Nkind (A) = N_Identifier
3080 and then Formal_Is_Used_Once (F))
3081
3082 or else
3083 (Nkind_In (A, N_Real_Literal,
3084 N_Integer_Literal,
3085 N_Character_Literal)
3086 and then not Address_Taken (F))
3087 then
3088 if Etype (F) /= Etype (A) then
3089 Set_Renamed_Object
3090 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3091 else
3092 Set_Renamed_Object (F, A);
3093 end if;
3094
3095 else
3096 Temp := Make_Temporary (Loc, 'C');
3097
3098 -- If the actual for an in/in-out parameter is a view conversion,
3099 -- make it into an unchecked conversion, given that an untagged
3100 -- type conversion is not a proper object for a renaming.
3101
3102 -- In-out conversions that involve real conversions have already
3103 -- been transformed in Expand_Actuals.
3104
3105 if Nkind (A) = N_Type_Conversion
3106 and then Ekind (F) /= E_In_Parameter
3107 then
3108 New_A :=
3109 Make_Unchecked_Type_Conversion (Loc,
3110 Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
3111 Expression => Relocate_Node (Expression (A)));
3112
3113 elsif Etype (F) /= Etype (A) then
3114 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3115 Temp_Typ := Etype (F);
3116
3117 else
3118 New_A := Relocate_Node (A);
3119 end if;
3120
3121 Set_Sloc (New_A, Sloc (N));
3122
3123 -- If the actual has a by-reference type, it cannot be copied,
3124 -- so its value is captured in a renaming declaration. Otherwise
3125 -- declare a local constant initialized with the actual.
3126
3127 -- We also use a renaming declaration for expressions of an array
3128 -- type that is not bit-packed, both for efficiency reasons and to
3129 -- respect the semantics of the call: in most cases the original
3130 -- call will pass the parameter by reference, and thus the inlined
3131 -- code will have the same semantics.
3132
3133 -- Finally, we need a renaming declaration in the case of limited
3134 -- types for which initialization cannot be by copy either.
3135
3136 if Ekind (F) = E_In_Parameter
3137 and then not Is_By_Reference_Type (Etype (A))
3138 and then not Is_Limited_Type (Etype (A))
3139 and then
3140 (not Is_Array_Type (Etype (A))
3141 or else not Is_Object_Reference (A)
3142 or else Is_Bit_Packed_Array (Etype (A)))
3143 then
3144 Decl :=
3145 Make_Object_Declaration (Loc,
3146 Defining_Identifier => Temp,
3147 Constant_Present => True,
3148 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3149 Expression => New_A);
3150 else
3151 Decl :=
3152 Make_Object_Renaming_Declaration (Loc,
3153 Defining_Identifier => Temp,
3154 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3155 Name => New_A);
3156 end if;
3157
3158 Append (Decl, Decls);
3159 Set_Renamed_Object (F, Temp);
3160 end if;
3161
3162 Next_Formal (F);
3163 Next_Actual (A);
3164 end loop;
3165
3166 -- Establish target of function call. If context is not assignment or
3167 -- declaration, create a temporary as a target. The declaration for the
3168 -- temporary may be subsequently optimized away if the body is a single
3169 -- expression, or if the left-hand side of the assignment is simple
3170 -- enough, i.e. an entity or an explicit dereference of one.
3171
3172 if Ekind (Subp) = E_Function then
3173 if Nkind (Parent (N)) = N_Assignment_Statement
3174 and then Is_Entity_Name (Name (Parent (N)))
3175 then
3176 Targ := Name (Parent (N));
3177
3178 elsif Nkind (Parent (N)) = N_Assignment_Statement
3179 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
3180 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3181 then
3182 Targ := Name (Parent (N));
3183
3184 elsif Nkind (Parent (N)) = N_Assignment_Statement
3185 and then Nkind (Name (Parent (N))) = N_Selected_Component
3186 and then Is_Entity_Name (Prefix (Name (Parent (N))))
3187 then
3188 Targ := New_Copy_Tree (Name (Parent (N)));
3189
3190 elsif Nkind (Parent (N)) = N_Object_Declaration
3191 and then Is_Limited_Type (Etype (Subp))
3192 then
3193 Targ := Defining_Identifier (Parent (N));
3194
3195 -- New semantics: In an object declaration avoid an extra copy
3196 -- of the result of a call to an inlined function that returns
3197 -- an unconstrained type
3198
3199 elsif Back_End_Inlining
3200 and then Nkind (Parent (N)) = N_Object_Declaration
3201 and then Is_Unc
3202 then
3203 Targ := Defining_Identifier (Parent (N));
3204
3205 else
3206 -- Replace call with temporary and create its declaration
3207
3208 Temp := Make_Temporary (Loc, 'C');
3209 Set_Is_Internal (Temp);
3210
3211 -- For the unconstrained case, the generated temporary has the
3212 -- same constrained declaration as the result variable. It may
3213 -- eventually be possible to remove that temporary and use the
3214 -- result variable directly.
3215
3216 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
3217 then
3218 Decl :=
3219 Make_Object_Declaration (Loc,
3220 Defining_Identifier => Temp,
3221 Object_Definition =>
3222 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3223
3224 Replace_Formals (Decl);
3225
3226 else
3227 Decl :=
3228 Make_Object_Declaration (Loc,
3229 Defining_Identifier => Temp,
3230 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
3231
3232 Set_Etype (Temp, Ret_Type);
3233 end if;
3234
3235 Set_No_Initialization (Decl);
3236 Append (Decl, Decls);
3237 Rewrite (N, New_Occurrence_Of (Temp, Loc));
3238 Targ := Temp;
3239 end if;
3240 end if;
3241
3242 Insert_Actions (N, Decls);
3243
3244 if Is_Unc_Decl then
3245
3246 -- Special management for inlining a call to a function that returns
3247 -- an unconstrained type and initializes an object declaration: we
3248 -- avoid generating undesired extra calls and goto statements.
3249
3250 -- Given:
3251 -- function Func (...) return ...
3252 -- begin
3253 -- declare
3254 -- Result : String (1 .. 4);
3255 -- begin
3256 -- Proc (Result, ...);
3257 -- return Result;
3258 -- end;
3259 -- end F;
3260
3261 -- Result : String := Func (...);
3262
3263 -- Replace this object declaration by:
3264
3265 -- Result : String (1 .. 4);
3266 -- Proc (Result, ...);
3267
3268 Remove_Homonym (Targ);
3269
3270 Decl :=
3271 Make_Object_Declaration
3272 (Loc,
3273 Defining_Identifier => Targ,
3274 Object_Definition =>
3275 New_Copy_Tree (Object_Definition (Parent (Targ1))));
3276 Replace_Formals (Decl);
3277 Rewrite (Parent (N), Decl);
3278 Analyze (Parent (N));
3279
3280 -- Avoid spurious warnings since we know that this declaration is
3281 -- referenced by the procedure call.
3282
3283 Set_Never_Set_In_Source (Targ, False);
3284
3285 -- Remove the local declaration of the extended return stmt from the
3286 -- inlined code
3287
3288 Remove (Parent (Targ1));
3289
3290 -- Update the reference to the result (since we have rewriten the
3291 -- object declaration)
3292
3293 declare
3294 Blk_Call_Stmt : Node_Id;
3295
3296 begin
3297 -- Capture the call to the procedure
3298
3299 Blk_Call_Stmt :=
3300 First (Statements (Handled_Statement_Sequence (Blk)));
3301 pragma Assert
3302 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
3303
3304 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
3305 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
3306 New_Occurrence_Of (Targ, Loc));
3307 end;
3308
3309 -- Remove the return statement
3310
3311 pragma Assert
3312 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3313 N_Simple_Return_Statement);
3314
3315 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3316 end if;
3317
3318 -- Traverse the tree and replace formals with actuals or their thunks.
3319 -- Attach block to tree before analysis and rewriting.
3320
3321 Replace_Formals (Blk);
3322 Set_Parent (Blk, N);
3323
3324 if GNATprove_Mode then
3325 null;
3326
3327 elsif not Comes_From_Source (Subp) or else Is_Predef then
3328 Reset_Slocs (Blk);
3329 end if;
3330
3331 if Is_Unc_Decl then
3332
3333 -- No action needed since return statement has been already removed
3334
3335 null;
3336
3337 elsif Present (Exit_Lab) then
3338
3339 -- If the body was a single expression, the single return statement
3340 -- and the corresponding label are useless.
3341
3342 if Num_Ret = 1
3343 and then
3344 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
3345 N_Goto_Statement
3346 then
3347 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
3348 else
3349 Append (Lab_Decl, (Declarations (Blk)));
3350 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
3351 end if;
3352 end if;
3353
3354 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
3355 -- on conflicting private views that Gigi would ignore. If this is a
3356 -- predefined unit, analyze with checks off, as is done in the non-
3357 -- inlined run-time units.
3358
3359 declare
3360 I_Flag : constant Boolean := In_Inlined_Body;
3361
3362 begin
3363 In_Inlined_Body := True;
3364
3365 if Is_Predef then
3366 declare
3367 Style : constant Boolean := Style_Check;
3368
3369 begin
3370 Style_Check := False;
3371
3372 -- Search for dispatching calls that use the Object.Operation
3373 -- notation using an Object that is a parameter of the inlined
3374 -- function. We reset the decoration of Operation to force
3375 -- the reanalysis of the inlined dispatching call because
3376 -- the actual object has been inlined.
3377
3378 Reset_Dispatching_Calls (Blk);
3379
3380 Analyze (Blk, Suppress => All_Checks);
3381 Style_Check := Style;
3382 end;
3383
3384 else
3385 Analyze (Blk);
3386 end if;
3387
3388 In_Inlined_Body := I_Flag;
3389 end;
3390
3391 if Ekind (Subp) = E_Procedure then
3392 Rewrite_Procedure_Call (N, Blk);
3393
3394 else
3395 Rewrite_Function_Call (N, Blk);
3396
3397 if Is_Unc_Decl then
3398 null;
3399
3400 -- For the unconstrained case, the replacement of the call has been
3401 -- made prior to the complete analysis of the generated declarations.
3402 -- Propagate the proper type now.
3403
3404 elsif Is_Unc then
3405 if Nkind (N) = N_Identifier then
3406 Set_Etype (N, Etype (Entity (N)));
3407 else
3408 Set_Etype (N, Etype (Targ1));
3409 end if;
3410 end if;
3411 end if;
3412
3413 Restore_Env;
3414
3415 -- Cleanup mapping between formals and actuals for other expansions
3416
3417 F := First_Formal (Subp);
3418 while Present (F) loop
3419 Set_Renamed_Object (F, Empty);
3420 Next_Formal (F);
3421 end loop;
3422 end Expand_Inlined_Call;
3423
3424 --------------------------
3425 -- Get_Code_Unit_Entity --
3426 --------------------------
3427
3428 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
3429 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
3430
3431 begin
3432 if Ekind (Unit) = E_Package_Body then
3433 Unit := Spec_Entity (Unit);
3434 end if;
3435
3436 return Unit;
3437 end Get_Code_Unit_Entity;
3438
3439 ------------------------------
3440 -- Has_Excluded_Declaration --
3441 ------------------------------
3442
3443 function Has_Excluded_Declaration
3444 (Subp : Entity_Id;
3445 Decls : List_Id) return Boolean
3446 is
3447 D : Node_Id;
3448
3449 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
3450 -- Nested subprograms make a given body ineligible for inlining, but
3451 -- we make an exception for instantiations of unchecked conversion.
3452 -- The body has not been analyzed yet, so check the name, and verify
3453 -- that the visible entity with that name is the predefined unit.
3454
3455 -----------------------------
3456 -- Is_Unchecked_Conversion --
3457 -----------------------------
3458
3459 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
3460 Id : constant Node_Id := Name (D);
3461 Conv : Entity_Id;
3462
3463 begin
3464 if Nkind (Id) = N_Identifier
3465 and then Chars (Id) = Name_Unchecked_Conversion
3466 then
3467 Conv := Current_Entity (Id);
3468
3469 elsif Nkind_In (Id, N_Selected_Component, N_Expanded_Name)
3470 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
3471 then
3472 Conv := Current_Entity (Selector_Name (Id));
3473 else
3474 return False;
3475 end if;
3476
3477 return Present (Conv)
3478 and then Is_Predefined_File_Name
3479 (Unit_File_Name (Get_Source_Unit (Conv)))
3480 and then Is_Intrinsic_Subprogram (Conv);
3481 end Is_Unchecked_Conversion;
3482
3483 -- Start of processing for Has_Excluded_Declaration
3484
3485 begin
3486 -- No action needed if the check is not needed
3487
3488 if not Check_Inlining_Restrictions then
3489 return False;
3490 end if;
3491
3492 D := First (Decls);
3493 while Present (D) loop
3494
3495 -- First declarations universally excluded
3496
3497 if Nkind (D) = N_Package_Declaration then
3498 Cannot_Inline
3499 ("cannot inline & (nested package declaration)?", D, Subp);
3500 return True;
3501
3502 elsif Nkind (D) = N_Package_Instantiation then
3503 Cannot_Inline
3504 ("cannot inline & (nested package instantiation)?", D, Subp);
3505 return True;
3506 end if;
3507
3508 -- Then declarations excluded only for front end inlining
3509
3510 if Back_End_Inlining then
3511 null;
3512
3513 elsif Nkind (D) = N_Task_Type_Declaration
3514 or else Nkind (D) = N_Single_Task_Declaration
3515 then
3516 Cannot_Inline
3517 ("cannot inline & (nested task type declaration)?", D, Subp);
3518 return True;
3519
3520 elsif Nkind (D) = N_Protected_Type_Declaration
3521 or else Nkind (D) = N_Single_Protected_Declaration
3522 then
3523 Cannot_Inline
3524 ("cannot inline & (nested protected type declaration)?",
3525 D, Subp);
3526 return True;
3527
3528 elsif Nkind (D) = N_Subprogram_Body then
3529 Cannot_Inline
3530 ("cannot inline & (nested subprogram)?", D, Subp);
3531 return True;
3532
3533 elsif Nkind (D) = N_Function_Instantiation
3534 and then not Is_Unchecked_Conversion (D)
3535 then
3536 Cannot_Inline
3537 ("cannot inline & (nested function instantiation)?", D, Subp);
3538 return True;
3539
3540 elsif Nkind (D) = N_Procedure_Instantiation then
3541 Cannot_Inline
3542 ("cannot inline & (nested procedure instantiation)?", D, Subp);
3543 return True;
3544
3545 -- Subtype declarations with predicates will generate predicate
3546 -- functions, i.e. nested subprogram bodies, so inlining is not
3547 -- possible.
3548
3549 elsif Nkind (D) = N_Subtype_Declaration
3550 and then Present (Aspect_Specifications (D))
3551 then
3552 declare
3553 A : Node_Id;
3554 A_Id : Aspect_Id;
3555
3556 begin
3557 A := First (Aspect_Specifications (D));
3558 while Present (A) loop
3559 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
3560
3561 if A_Id = Aspect_Predicate
3562 or else A_Id = Aspect_Static_Predicate
3563 or else A_Id = Aspect_Dynamic_Predicate
3564 then
3565 Cannot_Inline
3566 ("cannot inline & (subtype declaration with "
3567 & "predicate)?", D, Subp);
3568 return True;
3569 end if;
3570
3571 Next (A);
3572 end loop;
3573 end;
3574 end if;
3575
3576 Next (D);
3577 end loop;
3578
3579 return False;
3580 end Has_Excluded_Declaration;
3581
3582 ----------------------------
3583 -- Has_Excluded_Statement --
3584 ----------------------------
3585
3586 function Has_Excluded_Statement
3587 (Subp : Entity_Id;
3588 Stats : List_Id) return Boolean
3589 is
3590 S : Node_Id;
3591 E : Node_Id;
3592
3593 begin
3594 -- No action needed if the check is not needed
3595
3596 if not Check_Inlining_Restrictions then
3597 return False;
3598 end if;
3599
3600 S := First (Stats);
3601 while Present (S) loop
3602 if Nkind_In (S, N_Abort_Statement,
3603 N_Asynchronous_Select,
3604 N_Conditional_Entry_Call,
3605 N_Delay_Relative_Statement,
3606 N_Delay_Until_Statement,
3607 N_Selective_Accept,
3608 N_Timed_Entry_Call)
3609 then
3610 Cannot_Inline
3611 ("cannot inline & (non-allowed statement)?", S, Subp);
3612 return True;
3613
3614 elsif Nkind (S) = N_Block_Statement then
3615 if Present (Declarations (S))
3616 and then Has_Excluded_Declaration (Subp, Declarations (S))
3617 then
3618 return True;
3619
3620 elsif Present (Handled_Statement_Sequence (S)) then
3621 if not Back_End_Inlining
3622 and then
3623 Present
3624 (Exception_Handlers (Handled_Statement_Sequence (S)))
3625 then
3626 Cannot_Inline
3627 ("cannot inline& (exception handler)?",
3628 First (Exception_Handlers
3629 (Handled_Statement_Sequence (S))),
3630 Subp);
3631 return True;
3632
3633 elsif Has_Excluded_Statement
3634 (Subp, Statements (Handled_Statement_Sequence (S)))
3635 then
3636 return True;
3637 end if;
3638 end if;
3639
3640 elsif Nkind (S) = N_Case_Statement then
3641 E := First (Alternatives (S));
3642 while Present (E) loop
3643 if Has_Excluded_Statement (Subp, Statements (E)) then
3644 return True;
3645 end if;
3646
3647 Next (E);
3648 end loop;
3649
3650 elsif Nkind (S) = N_If_Statement then
3651 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
3652 return True;
3653 end if;
3654
3655 if Present (Elsif_Parts (S)) then
3656 E := First (Elsif_Parts (S));
3657 while Present (E) loop
3658 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
3659 return True;
3660 end if;
3661
3662 Next (E);
3663 end loop;
3664 end if;
3665
3666 if Present (Else_Statements (S))
3667 and then Has_Excluded_Statement (Subp, Else_Statements (S))
3668 then
3669 return True;
3670 end if;
3671
3672 elsif Nkind (S) = N_Loop_Statement
3673 and then Has_Excluded_Statement (Subp, Statements (S))
3674 then
3675 return True;
3676
3677 elsif Nkind (S) = N_Extended_Return_Statement then
3678 if Present (Handled_Statement_Sequence (S))
3679 and then
3680 Has_Excluded_Statement
3681 (Subp, Statements (Handled_Statement_Sequence (S)))
3682 then
3683 return True;
3684
3685 elsif not Back_End_Inlining
3686 and then Present (Handled_Statement_Sequence (S))
3687 and then
3688 Present (Exception_Handlers
3689 (Handled_Statement_Sequence (S)))
3690 then
3691 Cannot_Inline
3692 ("cannot inline& (exception handler)?",
3693 First (Exception_Handlers (Handled_Statement_Sequence (S))),
3694 Subp);
3695 return True;
3696 end if;
3697 end if;
3698
3699 Next (S);
3700 end loop;
3701
3702 return False;
3703 end Has_Excluded_Statement;
3704
3705 --------------------------
3706 -- Has_Initialized_Type --
3707 --------------------------
3708
3709 function Has_Initialized_Type (E : Entity_Id) return Boolean is
3710 E_Body : constant Node_Id := Subprogram_Body (E);
3711 Decl : Node_Id;
3712
3713 begin
3714 if No (E_Body) then -- imported subprogram
3715 return False;
3716
3717 else
3718 Decl := First (Declarations (E_Body));
3719 while Present (Decl) loop
3720 if Nkind (Decl) = N_Full_Type_Declaration
3721 and then Present (Init_Proc (Defining_Identifier (Decl)))
3722 then
3723 return True;
3724 end if;
3725
3726 Next (Decl);
3727 end loop;
3728 end if;
3729
3730 return False;
3731 end Has_Initialized_Type;
3732
3733 -----------------------
3734 -- Has_Single_Return --
3735 -----------------------
3736
3737 function Has_Single_Return (N : Node_Id) return Boolean is
3738 Return_Statement : Node_Id := Empty;
3739
3740 function Check_Return (N : Node_Id) return Traverse_Result;
3741
3742 ------------------
3743 -- Check_Return --
3744 ------------------
3745
3746 function Check_Return (N : Node_Id) return Traverse_Result is
3747 begin
3748 if Nkind (N) = N_Simple_Return_Statement then
3749 if Present (Expression (N))
3750 and then Is_Entity_Name (Expression (N))
3751 then
3752 if No (Return_Statement) then
3753 Return_Statement := N;
3754 return OK;
3755
3756 elsif Chars (Expression (N)) =
3757 Chars (Expression (Return_Statement))
3758 then
3759 return OK;
3760
3761 else
3762 return Abandon;
3763 end if;
3764
3765 -- A return statement within an extended return is a noop
3766 -- after inlining.
3767
3768 elsif No (Expression (N))
3769 and then
3770 Nkind (Parent (Parent (N))) = N_Extended_Return_Statement
3771 then
3772 return OK;
3773
3774 else
3775 -- Expression has wrong form
3776
3777 return Abandon;
3778 end if;
3779
3780 -- We can only inline a build-in-place function if it has a single
3781 -- extended return.
3782
3783 elsif Nkind (N) = N_Extended_Return_Statement then
3784 if No (Return_Statement) then
3785 Return_Statement := N;
3786 return OK;
3787
3788 else
3789 return Abandon;
3790 end if;
3791
3792 else
3793 return OK;
3794 end if;
3795 end Check_Return;
3796
3797 function Check_All_Returns is new Traverse_Func (Check_Return);
3798
3799 -- Start of processing for Has_Single_Return
3800
3801 begin
3802 if Check_All_Returns (N) /= OK then
3803 return False;
3804
3805 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
3806 return True;
3807
3808 else
3809 return Present (Declarations (N))
3810 and then Present (First (Declarations (N)))
3811 and then Chars (Expression (Return_Statement)) =
3812 Chars (Defining_Identifier (First (Declarations (N))));
3813 end if;
3814 end Has_Single_Return;
3815
3816 -----------------------------
3817 -- In_Main_Unit_Or_Subunit --
3818 -----------------------------
3819
3820 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
3821 Comp : Node_Id := Cunit (Get_Code_Unit (E));
3822
3823 begin
3824 -- Check whether the subprogram or package to inline is within the main
3825 -- unit or its spec or within a subunit. In either case there are no
3826 -- additional bodies to process. If the subprogram appears in a parent
3827 -- of the current unit, the check on whether inlining is possible is
3828 -- done in Analyze_Inlined_Bodies.
3829
3830 while Nkind (Unit (Comp)) = N_Subunit loop
3831 Comp := Library_Unit (Comp);
3832 end loop;
3833
3834 return Comp = Cunit (Main_Unit)
3835 or else Comp = Library_Unit (Cunit (Main_Unit));
3836 end In_Main_Unit_Or_Subunit;
3837
3838 ----------------
3839 -- Initialize --
3840 ----------------
3841
3842 procedure Initialize is
3843 begin
3844 Pending_Descriptor.Init;
3845 Pending_Instantiations.Init;
3846 Inlined_Bodies.Init;
3847 Successors.Init;
3848 Inlined.Init;
3849
3850 for J in Hash_Headers'Range loop
3851 Hash_Headers (J) := No_Subp;
3852 end loop;
3853
3854 Inlined_Calls := No_Elist;
3855 Backend_Calls := No_Elist;
3856 Backend_Inlined_Subps := No_Elist;
3857 Backend_Not_Inlined_Subps := No_Elist;
3858 end Initialize;
3859
3860 ------------------------
3861 -- Instantiate_Bodies --
3862 ------------------------
3863
3864 -- Generic bodies contain all the non-local references, so an
3865 -- instantiation does not need any more context than Standard
3866 -- itself, even if the instantiation appears in an inner scope.
3867 -- Generic associations have verified that the contract model is
3868 -- satisfied, so that any error that may occur in the analysis of
3869 -- the body is an internal error.
3870
3871 procedure Instantiate_Bodies is
3872 J : Nat;
3873 Info : Pending_Body_Info;
3874
3875 begin
3876 if Serious_Errors_Detected = 0 then
3877 Expander_Active := (Operating_Mode = Opt.Generate_Code);
3878 Push_Scope (Standard_Standard);
3879 To_Clean := New_Elmt_List;
3880
3881 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3882 Start_Generic;
3883 end if;
3884
3885 -- A body instantiation may generate additional instantiations, so
3886 -- the following loop must scan to the end of a possibly expanding
3887 -- set (that's why we can't simply use a FOR loop here).
3888
3889 J := 0;
3890 while J <= Pending_Instantiations.Last
3891 and then Serious_Errors_Detected = 0
3892 loop
3893 Info := Pending_Instantiations.Table (J);
3894
3895 -- If the instantiation node is absent, it has been removed
3896 -- as part of unreachable code.
3897
3898 if No (Info.Inst_Node) then
3899 null;
3900
3901 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
3902 Instantiate_Package_Body (Info);
3903 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
3904
3905 else
3906 Instantiate_Subprogram_Body (Info);
3907 end if;
3908
3909 J := J + 1;
3910 end loop;
3911
3912 -- Reset the table of instantiations. Additional instantiations
3913 -- may be added through inlining, when additional bodies are
3914 -- analyzed.
3915
3916 Pending_Instantiations.Init;
3917
3918 -- We can now complete the cleanup actions of scopes that contain
3919 -- pending instantiations (skipped for generic units, since we
3920 -- never need any cleanups in generic units).
3921
3922 if Expander_Active
3923 and then not Is_Generic_Unit (Main_Unit_Entity)
3924 then
3925 Cleanup_Scopes;
3926 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
3927 End_Generic;
3928 end if;
3929
3930 Pop_Scope;
3931 end if;
3932 end Instantiate_Bodies;
3933
3934 ---------------
3935 -- Is_Nested --
3936 ---------------
3937
3938 function Is_Nested (E : Entity_Id) return Boolean is
3939 Scop : Entity_Id;
3940
3941 begin
3942 Scop := Scope (E);
3943 while Scop /= Standard_Standard loop
3944 if Ekind (Scop) in Subprogram_Kind then
3945 return True;
3946
3947 elsif Ekind (Scop) = E_Task_Type
3948 or else Ekind (Scop) = E_Entry
3949 or else Ekind (Scop) = E_Entry_Family
3950 then
3951 return True;
3952 end if;
3953
3954 Scop := Scope (Scop);
3955 end loop;
3956
3957 return False;
3958 end Is_Nested;
3959
3960 ------------------------
3961 -- List_Inlining_Info --
3962 ------------------------
3963
3964 procedure List_Inlining_Info is
3965 Elmt : Elmt_Id;
3966 Nod : Node_Id;
3967 Count : Nat;
3968
3969 begin
3970 if not Debug_Flag_Dot_J then
3971 return;
3972 end if;
3973
3974 -- Generate listing of calls inlined by the frontend
3975
3976 if Present (Inlined_Calls) then
3977 Count := 0;
3978 Elmt := First_Elmt (Inlined_Calls);
3979 while Present (Elmt) loop
3980 Nod := Node (Elmt);
3981
3982 if In_Extended_Main_Code_Unit (Nod) then
3983 Count := Count + 1;
3984
3985 if Count = 1 then
3986 Write_Str ("List of calls inlined by the frontend");
3987 Write_Eol;
3988 end if;
3989
3990 Write_Str (" ");
3991 Write_Int (Count);
3992 Write_Str (":");
3993 Write_Location (Sloc (Nod));
3994 Write_Str (":");
3995 Output.Write_Eol;
3996 end if;
3997
3998 Next_Elmt (Elmt);
3999 end loop;
4000 end if;
4001
4002 -- Generate listing of calls passed to the backend
4003
4004 if Present (Backend_Calls) then
4005 Count := 0;
4006
4007 Elmt := First_Elmt (Backend_Calls);
4008 while Present (Elmt) loop
4009 Nod := Node (Elmt);
4010
4011 if In_Extended_Main_Code_Unit (Nod) then
4012 Count := Count + 1;
4013
4014 if Count = 1 then
4015 Write_Str ("List of inlined calls passed to the backend");
4016 Write_Eol;
4017 end if;
4018
4019 Write_Str (" ");
4020 Write_Int (Count);
4021 Write_Str (":");
4022 Write_Location (Sloc (Nod));
4023 Output.Write_Eol;
4024 end if;
4025
4026 Next_Elmt (Elmt);
4027 end loop;
4028 end if;
4029
4030 -- Generate listing of subprograms passed to the backend
4031
4032 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
4033 Count := 0;
4034
4035 Elmt := First_Elmt (Backend_Inlined_Subps);
4036 while Present (Elmt) loop
4037 Nod := Node (Elmt);
4038
4039 Count := Count + 1;
4040
4041 if Count = 1 then
4042 Write_Str
4043 ("List of inlined subprograms passed to the backend");
4044 Write_Eol;
4045 end if;
4046
4047 Write_Str (" ");
4048 Write_Int (Count);
4049 Write_Str (":");
4050 Write_Name (Chars (Nod));
4051 Write_Str (" (");
4052 Write_Location (Sloc (Nod));
4053 Write_Str (")");
4054 Output.Write_Eol;
4055
4056 Next_Elmt (Elmt);
4057 end loop;
4058 end if;
4059
4060 -- Generate listing of subprograms that cannot be inlined by the backend
4061
4062 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
4063 Count := 0;
4064
4065 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
4066 while Present (Elmt) loop
4067 Nod := Node (Elmt);
4068
4069 Count := Count + 1;
4070
4071 if Count = 1 then
4072 Write_Str
4073 ("List of subprograms that cannot be inlined by the backend");
4074 Write_Eol;
4075 end if;
4076
4077 Write_Str (" ");
4078 Write_Int (Count);
4079 Write_Str (":");
4080 Write_Name (Chars (Nod));
4081 Write_Str (" (");
4082 Write_Location (Sloc (Nod));
4083 Write_Str (")");
4084 Output.Write_Eol;
4085
4086 Next_Elmt (Elmt);
4087 end loop;
4088 end if;
4089 end List_Inlining_Info;
4090
4091 ----------
4092 -- Lock --
4093 ----------
4094
4095 procedure Lock is
4096 begin
4097 Pending_Instantiations.Locked := True;
4098 Inlined_Bodies.Locked := True;
4099 Successors.Locked := True;
4100 Inlined.Locked := True;
4101 Pending_Instantiations.Release;
4102 Inlined_Bodies.Release;
4103 Successors.Release;
4104 Inlined.Release;
4105 end Lock;
4106
4107 --------------------------------
4108 -- Remove_Aspects_And_Pragmas --
4109 --------------------------------
4110
4111 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
4112 procedure Remove_Items (List : List_Id);
4113 -- Remove all useless aspects/pragmas from a particular list
4114
4115 ------------------
4116 -- Remove_Items --
4117 ------------------
4118
4119 procedure Remove_Items (List : List_Id) is
4120 Item : Node_Id;
4121 Item_Id : Node_Id;
4122 Next_Item : Node_Id;
4123
4124 begin
4125 -- Traverse the list looking for an aspect specification or a pragma
4126
4127 Item := First (List);
4128 while Present (Item) loop
4129 Next_Item := Next (Item);
4130
4131 if Nkind (Item) = N_Aspect_Specification then
4132 Item_Id := Identifier (Item);
4133 elsif Nkind (Item) = N_Pragma then
4134 Item_Id := Pragma_Identifier (Item);
4135 else
4136 Item_Id := Empty;
4137 end if;
4138
4139 if Present (Item_Id)
4140 and then Nam_In (Chars (Item_Id), Name_Contract_Cases,
4141 Name_Global,
4142 Name_Depends,
4143 Name_Postcondition,
4144 Name_Precondition,
4145 Name_Refined_Global,
4146 Name_Refined_Depends,
4147 Name_Refined_Post,
4148 Name_Test_Case,
4149 Name_Unmodified,
4150 Name_Unreferenced)
4151 then
4152 Remove (Item);
4153 end if;
4154
4155 Item := Next_Item;
4156 end loop;
4157 end Remove_Items;
4158
4159 -- Start of processing for Remove_Aspects_And_Pragmas
4160
4161 begin
4162 Remove_Items (Aspect_Specifications (Body_Decl));
4163 Remove_Items (Declarations (Body_Decl));
4164 end Remove_Aspects_And_Pragmas;
4165
4166 --------------------------
4167 -- Remove_Dead_Instance --
4168 --------------------------
4169
4170 procedure Remove_Dead_Instance (N : Node_Id) is
4171 J : Int;
4172
4173 begin
4174 J := 0;
4175 while J <= Pending_Instantiations.Last loop
4176 if Pending_Instantiations.Table (J).Inst_Node = N then
4177 Pending_Instantiations.Table (J).Inst_Node := Empty;
4178 return;
4179 end if;
4180
4181 J := J + 1;
4182 end loop;
4183 end Remove_Dead_Instance;
4184
4185 end Inline;