]> git.ipfire.org Git - thirdparty/gcc.git/blame - gcc/ada/inline.adb
amdgcn: fix vec_ucmp infinite recursion
[thirdparty/gcc.git] / gcc / ada / inline.adb
CommitLineData
38cbfe40
RK
1------------------------------------------------------------------------------
2-- --
3-- GNAT COMPILER COMPONENTS --
4-- --
5-- I N L I N E --
6-- --
7-- B o d y --
8-- --
0c28cf56 9-- Copyright (C) 1992-2025, Free Software Foundation, Inc. --
38cbfe40
RK
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- --
b5c84c3c 13-- ware Foundation; either version 3, or (at your option) any later ver- --
38cbfe40
RK
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 --
b5c84c3c
RD
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. --
38cbfe40
RK
20-- --
21-- GNAT was originally developed by the GNAT team at New York University. --
71ff80dc 22-- Extensive contributions were provided by Ada Core Technologies Inc. --
38cbfe40
RK
23-- --
24------------------------------------------------------------------------------
25
4b96d386 26with Alloc;
104f58db
BD
27with Aspects; use Aspects;
28with Atree; use Atree;
29with Debug; use Debug;
30with Einfo; use Einfo;
76f9c7f4 31with Einfo.Entities; use Einfo.Entities;
104f58db
BD
32with Einfo.Utils; use Einfo.Utils;
33with Elists; use Elists;
34with Errout; use Errout;
104f58db
BD
35with Exp_Ch6; use Exp_Ch6;
36with Exp_Ch7; use Exp_Ch7;
37with Exp_Tss; use Exp_Tss;
38with Exp_Util; use Exp_Util;
39with Fname; use Fname;
40with Fname.UF; use Fname.UF;
41with Lib; use Lib;
42with Namet; use Namet;
43with Nmake; use Nmake;
44with Nlists; use Nlists;
45with Output; use Output;
46with Sem_Aux; use Sem_Aux;
47with Sem_Ch8; use Sem_Ch8;
48with Sem_Ch10; use Sem_Ch10;
49with Sem_Ch12; use Sem_Ch12;
50with Sem_Prag; use Sem_Prag;
51with Sem_Res; use Sem_Res;
52with Sem_Util; use Sem_Util;
53with Sinfo; use Sinfo;
54with Sinfo.Nodes; use Sinfo.Nodes;
55with Sinfo.Utils; use Sinfo.Utils;
56with Sinput; use Sinput;
57with Snames; use Snames;
58with Stand; use Stand;
4b96d386 59with Table;
104f58db
BD
60with Tbuild; use Tbuild;
61with Uintp; use Uintp;
62with Uname; use Uname;
4b96d386
EB
63
64with GNAT.HTable;
38cbfe40
RK
65
66package body Inline is
67
16b10ccc
AC
68 Check_Inlining_Restrictions : constant Boolean := True;
69 -- In the following cases the frontend rejects inlining because they
70 -- are not handled well by the backend. This variable facilitates
71 -- disabling these restrictions to evaluate future versions of the
72 -- GCC backend in which some of the restrictions may be supported.
73 --
74 -- - subprograms that have:
75 -- - nested subprograms
76 -- - instantiations
77 -- - package declarations
78 -- - task or protected object declarations
79 -- - some of the following statements:
80 -- - abort
81 -- - asynchronous-select
82 -- - conditional-entry-call
83 -- - delay-relative
84 -- - delay-until
85 -- - selective-accept
86 -- - timed-entry-call
87
88 Inlined_Calls : Elist_Id;
89 -- List of frontend inlined calls
90
91 Backend_Calls : Elist_Id;
92 -- List of inline calls passed to the backend
93
4b96d386
EB
94 Backend_Instances : Elist_Id;
95 -- List of instances inlined for the backend
96
16b10ccc
AC
97 Backend_Inlined_Subps : Elist_Id;
98 -- List of subprograms inlined by the backend
99
100 Backend_Not_Inlined_Subps : Elist_Id;
101 -- List of subprograms that cannot be inlined by the backend
102
4b96d386
EB
103 -----------------------------
104 -- Pending_Instantiations --
105 -----------------------------
106
107 -- We make entries in this table for the pending instantiations of generic
108 -- bodies that are created during semantic analysis. After the analysis is
109 -- complete, calling Instantiate_Bodies performs the actual instantiations.
110
111 package Pending_Instantiations is new Table.Table (
112 Table_Component_Type => Pending_Body_Info,
113 Table_Index_Type => Int,
114 Table_Low_Bound => 0,
115 Table_Initial => Alloc.Pending_Instantiations_Initial,
116 Table_Increment => Alloc.Pending_Instantiations_Increment,
117 Table_Name => "Pending_Instantiations");
118
119 -------------------------------------
120 -- Called_Pending_Instantiations --
121 -------------------------------------
122
123 -- With back-end inlining, the pending instantiations that are not in the
124 -- main unit or subunit are performed only after a call to the subprogram
125 -- instance, or to a subprogram within the package instance, is inlined.
126 -- Since such a call can be within a subsequent pending instantiation,
127 -- we make entries in this table that stores the index of these "called"
128 -- pending instantiations and perform them when the table is populated.
129
130 package Called_Pending_Instantiations is new Table.Table (
131 Table_Component_Type => Int,
132 Table_Index_Type => Int,
133 Table_Low_Bound => 0,
134 Table_Initial => Alloc.Pending_Instantiations_Initial,
135 Table_Increment => Alloc.Pending_Instantiations_Increment,
136 Table_Name => "Called_Pending_Instantiations");
137
138 ---------------------------------
139 -- To_Pending_Instantiations --
140 ---------------------------------
141
142 -- With back-end inlining, we also need to have a map from the pending
143 -- instantiations to their index in the Pending_Instantiations table.
144
145 Node_Table_Size : constant := 257;
146 -- Number of headers in hash table
147
148 subtype Node_Header_Num is Integer range 0 .. Node_Table_Size - 1;
149 -- Range of headers in hash table
150
151 function Node_Hash (Id : Node_Id) return Node_Header_Num;
152 -- Simple hash function for Node_Ids
153
154 package To_Pending_Instantiations is new GNAT.Htable.Simple_HTable
155 (Header_Num => Node_Header_Num,
156 Element => Int,
157 No_Element => -1,
158 Key => Node_Id,
159 Hash => Node_Hash,
160 Equal => "=");
161
162 -----------------
163 -- Node_Hash --
164 -----------------
165
166 function Node_Hash (Id : Node_Id) return Node_Header_Num is
167 begin
168 return Node_Header_Num (Id mod Node_Table_Size);
169 end Node_Hash;
170
38cbfe40
RK
171 --------------------
172 -- Inlined Bodies --
173 --------------------
174
175 -- Inlined functions are actually placed in line by the backend if the
176 -- corresponding bodies are available (i.e. compiled). Whenever we find
177 -- a call to an inlined subprogram, we add the name of the enclosing
178 -- compilation unit to a worklist. After all compilation, and after
179 -- expansion of generic bodies, we traverse the list of pending bodies
180 -- and compile them as well.
181
182 package Inlined_Bodies is new Table.Table (
183 Table_Component_Type => Entity_Id,
184 Table_Index_Type => Int,
185 Table_Low_Bound => 0,
186 Table_Initial => Alloc.Inlined_Bodies_Initial,
187 Table_Increment => Alloc.Inlined_Bodies_Increment,
188 Table_Name => "Inlined_Bodies");
189
190 -----------------------
191 -- Inline Processing --
192 -----------------------
193
194 -- For each call to an inlined subprogram, we make entries in a table
8a49a499 195 -- that stores caller and callee, and indicates the call direction from
38cbfe40
RK
196 -- one to the other. We also record the compilation unit that contains
197 -- the callee. After analyzing the bodies of all such compilation units,
8a49a499
AC
198 -- we compute the transitive closure of inlined subprograms called from
199 -- the main compilation unit and make it available to the code generator
200 -- in no particular order, thus allowing cycles in the call graph.
38cbfe40
RK
201
202 Last_Inlined : Entity_Id := Empty;
203
204 -- For each entry in the table we keep a list of successors in topological
205 -- order, i.e. callers of the current subprogram.
206
207 type Subp_Index is new Nat;
208 No_Subp : constant Subp_Index := 0;
209
9de61fcb 210 -- The subprogram entities are hashed into the Inlined table
38cbfe40
RK
211
212 Num_Hash_Headers : constant := 512;
213
214 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
215 of Subp_Index;
216
217 type Succ_Index is new Nat;
218 No_Succ : constant Succ_Index := 0;
219
220 type Succ_Info is record
221 Subp : Subp_Index;
222 Next : Succ_Index;
223 end record;
224
3f80a182
AC
225 -- The following table stores list elements for the successor lists. These
226 -- lists cannot be chained directly through entries in the Inlined table,
227 -- because a given subprogram can appear in several such lists.
38cbfe40
RK
228
229 package Successors is new Table.Table (
230 Table_Component_Type => Succ_Info,
231 Table_Index_Type => Succ_Index,
232 Table_Low_Bound => 1,
233 Table_Initial => Alloc.Successors_Initial,
234 Table_Increment => Alloc.Successors_Increment,
235 Table_Name => "Successors");
236
237 type Subp_Info is record
238 Name : Entity_Id := Empty;
8a49a499 239 Next : Subp_Index := No_Subp;
38cbfe40 240 First_Succ : Succ_Index := No_Succ;
38cbfe40 241 Main_Call : Boolean := False;
8a49a499 242 Processed : Boolean := False;
38cbfe40
RK
243 end record;
244
245 package Inlined is new Table.Table (
246 Table_Component_Type => Subp_Info,
247 Table_Index_Type => Subp_Index,
248 Table_Low_Bound => 1,
249 Table_Initial => Alloc.Inlined_Initial,
250 Table_Increment => Alloc.Inlined_Increment,
251 Table_Name => "Inlined");
252
253 -----------------------
254 -- Local Subprograms --
255 -----------------------
256
38cbfe40
RK
257 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
258 -- Make two entries in Inlined table, for an inlined subprogram being
259 -- called, and for the inlined subprogram that contains the call. If
260 -- the call is in the main compilation unit, Caller is Empty.
261
4b96d386 262 procedure Add_Inlined_Instance (E : Entity_Id);
604801a4 263 -- Add instance E to the list of inlined instances for the unit
4b96d386 264
4ef36ac7 265 procedure Add_Inlined_Subprogram (E : Entity_Id);
4b96d386 266 -- Add subprogram E to the list of inlined subprograms for the unit
6c26bac2 267
38cbfe40
RK
268 function Add_Subp (E : Entity_Id) return Subp_Index;
269 -- Make entry in Inlined table for subprogram E, or return table index
270 -- that already holds E.
271
bbab2db3
GD
272 procedure Establish_Actual_Mapping_For_Inlined_Call
273 (N : Node_Id;
274 Subp : Entity_Id;
275 Decls : List_Id;
276 Body_Or_Expr_To_Check : Node_Id);
277 -- Establish a mapping from formals to actuals in the call N for the target
278 -- subprogram Subp, and create temporaries or renamings when needed for the
279 -- actuals that are expressions (except for actuals given by simple entity
280 -- names or literals) or that are scalars that require copying to preserve
281 -- semantics. Any temporary objects that are created are inserted in Decls.
282 -- Body_Or_Expr_To_Check indicates the target body (or possibly expression
283 -- of an expression function), which may be traversed to count formal uses.
284
6c26bac2
AC
285 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
286 pragma Inline (Get_Code_Unit_Entity);
287 -- Return the entity node for the unit containing E. Always return the spec
288 -- for a package.
289
38cbfe40
RK
290 function Has_Initialized_Type (E : Entity_Id) return Boolean;
291 -- If a candidate for inlining contains type declarations for types with
31101470 292 -- nontrivial initialization procedures, they are not worth inlining.
38cbfe40 293
6c26bac2
AC
294 function Has_Single_Return (N : Node_Id) return Boolean;
295 -- In general we cannot inline functions that return unconstrained type.
c4ea2978
YM
296 -- However, we can handle such functions if all return statements return
297 -- a local variable that is the first declaration in the body of the
298 -- function. In that case the call can be replaced by that local
299 -- variable as is done for other inlined calls.
6c26bac2
AC
300
301 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean;
302 -- Return True if E is in the main unit or its spec or in a subunit
303
38cbfe40 304 function Is_Nested (E : Entity_Id) return Boolean;
3f80a182
AC
305 -- If the function is nested inside some other function, it will always
306 -- be compiled if that function is, so don't add it to the inline list.
307 -- We cannot compile a nested function outside the scope of the containing
308 -- function anyway. This is also the case if the function is defined in a
309 -- task body or within an entry (for example, an initialization procedure).
38cbfe40 310
697b781a
AC
311 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id);
312 -- Remove all aspects and/or pragmas that have no meaning in inlined body
313 -- Body_Decl. The analysis of these items is performed on the non-inlined
314 -- body. The items currently removed are:
dcc60142 315 -- Always_Terminates
697b781a
AC
316 -- Contract_Cases
317 -- Global
318 -- Depends
61285c48 319 -- Exceptional_Cases
f49b098e 320 -- Exit_Cases
697b781a
AC
321 -- Postcondition
322 -- Precondition
899c0d2d 323 -- Program_Exit
697b781a
AC
324 -- Refined_Global
325 -- Refined_Depends
326 -- Refined_Post
afa1ffd4 327 -- Subprogram_Variant
697b781a
AC
328 -- Test_Case
329 -- Unmodified
330 -- Unreferenced
38cbfe40 331
bbab2db3 332 procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id);
19e7eae5
BD
333 -- Reset the Renamed_Object field to Empty on all formals of Subp, which
334 -- can be set by a call to Establish_Actual_Mapping_For_Inlined_Call.
bbab2db3 335
38cbfe40
RK
336 ------------------------------
337 -- Deferred Cleanup Actions --
338 ------------------------------
339
0c1d2675
EB
340 -- The cleanup actions for scopes that contain package instantiations with
341 -- a body are delayed until after the package body is instantiated. because
342 -- the body may contain finalizable objects or other constructs that affect
343 -- the cleanup code. A scope that contains such instantiations only needs
344 -- to be finalized once, even though it may contain more than one instance.
345 -- We keep a list of scopes that must still be finalized and Cleanup_Scopes
346 -- will be invoked after all the body instantiations have been completed.
38cbfe40
RK
347
348 To_Clean : Elist_Id;
349
0c1d2675 350 procedure Add_Scope_To_Clean (Scop : Entity_Id);
9de61fcb 351 -- Build set of scopes on which cleanup actions must be performed
38cbfe40
RK
352
353 procedure Cleanup_Scopes;
9de61fcb 354 -- Complete cleanup actions on scopes that need it
38cbfe40
RK
355
356 --------------
357 -- Add_Call --
358 --------------
359
360 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
fbf5a39b 361 P1 : constant Subp_Index := Add_Subp (Called);
38cbfe40
RK
362 P2 : Subp_Index;
363 J : Succ_Index;
364
365 begin
366 if Present (Caller) then
367 P2 := Add_Subp (Caller);
368
8a49a499 369 -- Add P1 to the list of successors of P2, if not already there.
38cbfe40
RK
370 -- Note that P2 may contain more than one call to P1, and only
371 -- one needs to be recorded.
372
8a49a499 373 J := Inlined.Table (P2).First_Succ;
38cbfe40 374 while J /= No_Succ loop
8a49a499 375 if Successors.Table (J).Subp = P1 then
38cbfe40
RK
376 return;
377 end if;
378
379 J := Successors.Table (J).Next;
380 end loop;
381
8a49a499 382 -- On exit, make a successor entry for P1
38cbfe40
RK
383
384 Successors.Increment_Last;
8a49a499 385 Successors.Table (Successors.Last).Subp := P1;
38cbfe40 386 Successors.Table (Successors.Last).Next :=
8a49a499
AC
387 Inlined.Table (P2).First_Succ;
388 Inlined.Table (P2).First_Succ := Successors.Last;
38cbfe40
RK
389 else
390 Inlined.Table (P1).Main_Call := True;
391 end if;
392 end Add_Call;
393
394 ----------------------
395 -- Add_Inlined_Body --
396 ----------------------
397
cf27c5a2 398 procedure Add_Inlined_Body (E : Entity_Id; N : Node_Id) is
38cbfe40 399
4c7be310
AC
400 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package);
401 -- Level of inlining for the call: Dont_Inline means no inlining,
402 -- Inline_Call means that only the call is considered for inlining,
403 -- Inline_Package means that the call is considered for inlining and
404 -- its package compiled and scanned for more inlining opportunities.
405
c581c520
PMR
406 function Is_Non_Loading_Expression_Function
407 (Id : Entity_Id) return Boolean;
408 -- Determine whether arbitrary entity Id denotes a subprogram which is
409 -- either
410 --
411 -- * An expression function
412 --
413 -- * A function completed by an expression function where both the
414 -- spec and body are in the same context.
415
4c7be310 416 function Must_Inline return Inline_Level_Type;
38cbfe40
RK
417 -- Inlining is only done if the call statement N is in the main unit,
418 -- or within the body of another inlined subprogram.
419
c581c520
PMR
420 ----------------------------------------
421 -- Is_Non_Loading_Expression_Function --
422 ----------------------------------------
423
424 function Is_Non_Loading_Expression_Function
425 (Id : Entity_Id) return Boolean
426 is
427 Body_Decl : Node_Id;
428 Body_Id : Entity_Id;
429 Spec_Decl : Node_Id;
430
431 begin
432 -- A stand-alone expression function is transformed into a spec-body
433 -- pair in-place. Since both the spec and body are in the same list,
434 -- the inlining of such an expression function does not need to load
435 -- anything extra.
436
437 if Is_Expression_Function (Id) then
438 return True;
439
440 -- A function may be completed by an expression function
441
442 elsif Ekind (Id) = E_Function then
443 Spec_Decl := Unit_Declaration_Node (Id);
444
445 if Nkind (Spec_Decl) = N_Subprogram_Declaration then
446 Body_Id := Corresponding_Body (Spec_Decl);
447
448 if Present (Body_Id) then
449 Body_Decl := Unit_Declaration_Node (Body_Id);
450
451 -- The inlining of a completing expression function does
452 -- not need to load anything extra when both the spec and
453 -- body are in the same context.
454
455 return
456 Was_Expression_Function (Body_Decl)
457 and then Parent (Spec_Decl) = Parent (Body_Decl);
458 end if;
459 end if;
460 end if;
461
462 return False;
463 end Is_Non_Loading_Expression_Function;
464
fbf5a39b
AC
465 -----------------
466 -- Must_Inline --
467 -----------------
468
4c7be310 469 function Must_Inline return Inline_Level_Type is
a99ada67 470 Scop : Entity_Id;
38cbfe40
RK
471 Comp : Node_Id;
472
473 begin
fbf5a39b 474 -- Check if call is in main unit
38cbfe40 475
a99ada67
RD
476 Scop := Current_Scope;
477
478 -- Do not try to inline if scope is standard. This could happen, for
479 -- example, for a call to Add_Global_Declaration, and it causes
480 -- trouble to try to inline at this level.
481
482 if Scop = Standard_Standard then
4c7be310 483 return Dont_Inline;
a99ada67
RD
484 end if;
485
486 -- Otherwise lookup scope stack to outer scope
487
38cbfe40
RK
488 while Scope (Scop) /= Standard_Standard
489 and then not Is_Child_Unit (Scop)
490 loop
491 Scop := Scope (Scop);
492 end loop;
493
494 Comp := Parent (Scop);
38cbfe40
RK
495 while Nkind (Comp) /= N_Compilation_Unit loop
496 Comp := Parent (Comp);
497 end loop;
498
4c7be310
AC
499 -- If the call is in the main unit, inline the call and compile the
500 -- package of the subprogram to find more calls to be inlined.
501
fbf5a39b 502 if Comp = Cunit (Main_Unit)
492f9cdf 503 or else Comp = Other_Comp_Unit (Cunit (Main_Unit))
38cbfe40
RK
504 then
505 Add_Call (E);
4c7be310 506 return Inline_Package;
38cbfe40
RK
507 end if;
508
4ef36ac7
AC
509 -- The call is not in the main unit. See if it is in some subprogram
510 -- that can be inlined outside its unit. If so, inline the call and,
511 -- if the inlining level is set to 1, stop there; otherwise also
512 -- compile the package as above.
38cbfe40
RK
513
514 Scop := Current_Scope;
515 while Scope (Scop) /= Standard_Standard
516 and then not Is_Child_Unit (Scop)
517 loop
4ef36ac7
AC
518 if Is_Overloadable (Scop)
519 and then Is_Inlined (Scop)
520 and then not Is_Nested (Scop)
521 then
38cbfe40 522 Add_Call (E, Scop);
2137e8a6 523
4c7be310
AC
524 if Inline_Level = 1 then
525 return Inline_Call;
526 else
527 return Inline_Package;
528 end if;
38cbfe40
RK
529 end if;
530
531 Scop := Scope (Scop);
532 end loop;
533
4c7be310 534 return Dont_Inline;
38cbfe40
RK
535 end Must_Inline;
536
4b96d386
EB
537 Inst : Entity_Id;
538 Inst_Decl : Node_Id;
4b96d386 539 Level : Inline_Level_Type;
4c7be310 540
38cbfe40
RK
541 -- Start of processing for Add_Inlined_Body
542
543 begin
cf27c5a2
EB
544 Append_New_Elmt (N, To => Backend_Calls);
545
4b96d386
EB
546 -- Skip subprograms that cannot or need not be inlined outside their
547 -- unit or parent subprogram.
4ef36ac7
AC
548
549 if Is_Abstract_Subprogram (E)
550 or else Convention (E) = Convention_Protected
4b96d386 551 or else In_Main_Unit_Or_Subunit (E)
4ef36ac7
AC
552 or else Is_Nested (E)
553 then
554 return;
555 end if;
556
2e885a6f
AC
557 -- Find out whether the call must be inlined. Unless the result is
558 -- Dont_Inline, Must_Inline also creates an edge for the call in the
559 -- callgraph; however, it will not be activated until after Is_Called
560 -- is set on the subprogram.
561
562 Level := Must_Inline;
563
564 if Level = Dont_Inline then
565 return;
566 end if;
567
4b96d386
EB
568 -- If a previous call to the subprogram has been inlined, nothing to do
569
570 if Is_Called (E) then
571 return;
572 end if;
573
574 -- If the subprogram is an instance, then inline the instance
575
576 if Is_Generic_Instance (E) then
577 Add_Inlined_Instance (E);
578 end if;
579
580 -- Mark the subprogram as called
581
582 Set_Is_Called (E);
583
2e885a6f
AC
584 -- If the call was generated by the compiler and is to a subprogram in
585 -- a run-time unit, we need to suppress debugging information for it,
586 -- so that the code that is eventually inlined will not affect the
587 -- debugging of the program. We do not do it if the call comes from
588 -- source because, even if the call is inlined, the user may expect it
589 -- to be present in the debugging information.
590
591 if not Comes_From_Source (N)
592 and then In_Extended_Main_Source_Unit (N)
8ab31c0c 593 and then Is_Predefined_Unit (Get_Source_Unit (E))
2e885a6f
AC
594 then
595 Set_Needs_Debug_Info (E, False);
596 end if;
597
c581c520
PMR
598 -- If the subprogram is an expression function, or is completed by one
599 -- where both the spec and body are in the same context, then there is
600 -- no need to load any package body since the body of the function is
601 -- in the spec.
2e885a6f 602
c581c520 603 if Is_Non_Loading_Expression_Function (E) then
2e885a6f
AC
604 return;
605 end if;
606
38cbfe40 607 -- Find unit containing E, and add to list of inlined bodies if needed.
38cbfe40
RK
608 -- Library-level functions must be handled specially, because there is
609 -- no enclosing package to retrieve. In this case, it is the body of
610 -- the function that will have to be loaded.
611
2e885a6f
AC
612 declare
613 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
cf27c5a2 614
2e885a6f
AC
615 begin
616 if Pack = E then
2e885a6f
AC
617 Inlined_Bodies.Increment_Last;
618 Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
619
49209838
EB
620 else
621 pragma Assert (Ekind (Pack) = E_Package);
2e885a6f 622
4b96d386
EB
623 -- If the subprogram is within an instance, inline the instance
624
625 if Comes_From_Source (E) then
626 Inst := Scope (E);
627
628 while Present (Inst) and then Inst /= Standard_Standard loop
629 exit when Is_Generic_Instance (Inst);
630 Inst := Scope (Inst);
631 end loop;
632
633 if Present (Inst)
634 and then Is_Generic_Instance (Inst)
635 and then not Is_Called (Inst)
636 then
4b96d386 637 Inst_Decl := Unit_Declaration_Node (Inst);
a4bbe10d
EB
638
639 -- Do not inline the instance if the body already exists,
6c87c83b 640 -- or the instance node is simply missing.
a4bbe10d 641
4b96d386 642 if Present (Corresponding_Body (Inst_Decl))
6c87c83b
EB
643 or else (Nkind (Parent (Inst_Decl)) /= N_Compilation_Unit
644 and then No (Next (Inst_Decl)))
4b96d386
EB
645 then
646 Set_Is_Called (Inst);
4b96d386 647 else
4b96d386
EB
648 Add_Inlined_Instance (Inst);
649 end if;
650 end if;
651 end if;
652
a4bbe10d 653 -- If the unit containing E is an instance, nothing more to do
4a6db9fd 654
2e885a6f
AC
655 if Is_Generic_Instance (Pack) then
656 null;
657
658 -- Do not inline the package if the subprogram is an init proc
659 -- or other internally generated subprogram, because in that
660 -- case the subprogram body appears in the same unit that
661 -- declares the type, and that body is visible to the back end.
662 -- Do not inline it either if it is in the main unit.
663 -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
31fde973
GD
664 -- calls if the back end takes care of inlining the call.
665 -- Note that Level is in Inline_Call | Inline_Package here.
2e885a6f 666
e49de265
BD
667 elsif ((Level = Inline_Call
668 and then Has_Pragma_Inline_Always (E)
669 and then Back_End_Inlining)
670 or else Level = Inline_Package)
2e885a6f
AC
671 and then not Is_Inlined (Pack)
672 and then not Is_Internal (E)
673 and then not In_Main_Unit_Or_Subunit (Pack)
674 then
675 Set_Is_Inlined (Pack);
38cbfe40 676 Inlined_Bodies.Increment_Last;
2e885a6f 677 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
38cbfe40 678 end if;
2e885a6f 679 end if;
cf27c5a2 680
2e885a6f
AC
681 -- Ensure that Analyze_Inlined_Bodies will be invoked after
682 -- completing the analysis of the current unit.
683
684 Inline_Processing_Required := True;
685 end;
38cbfe40
RK
686 end Add_Inlined_Body;
687
4b96d386
EB
688 --------------------------
689 -- Add_Inlined_Instance --
690 --------------------------
691
692 procedure Add_Inlined_Instance (E : Entity_Id) is
693 Decl_Node : constant Node_Id := Unit_Declaration_Node (E);
694 Index : Int;
695
696 begin
697 -- This machinery is only used with back-end inlining
698
699 if not Back_End_Inlining then
700 return;
701 end if;
702
703 -- Register the instance in the list
704
705 Append_New_Elmt (Decl_Node, To => Backend_Instances);
706
707 -- Retrieve the index of its corresponding pending instantiation
708 -- and mark this corresponding pending instantiation as needed.
709
710 Index := To_Pending_Instantiations.Get (Decl_Node);
711 if Index >= 0 then
712 Called_Pending_Instantiations.Append (Index);
713 else
714 pragma Assert (False);
715 null;
716 end if;
717
718 Set_Is_Called (E);
719 end Add_Inlined_Instance;
720
38cbfe40
RK
721 ----------------------------
722 -- Add_Inlined_Subprogram --
723 ----------------------------
724
4ef36ac7 725 procedure Add_Inlined_Subprogram (E : Entity_Id) is
d8d7e809 726 Decl : constant Node_Id := Parent (Declaration_Node (E));
feecad68 727 Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
38cbfe40 728
6c26bac2
AC
729 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id);
730 -- Append Subp to the list of subprograms inlined by the backend
731
732 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id);
733 -- Append Subp to the list of subprograms that cannot be inlined by
ea0c8cfb 734 -- the backend.
6c26bac2 735
6c26bac2
AC
736 -----------------------------------------
737 -- Register_Backend_Inlined_Subprogram --
738 -----------------------------------------
739
740 procedure Register_Backend_Inlined_Subprogram (Subp : Entity_Id) is
741 begin
21c51f53 742 Append_New_Elmt (Subp, To => Backend_Inlined_Subps);
6c26bac2
AC
743 end Register_Backend_Inlined_Subprogram;
744
745 ---------------------------------------------
746 -- Register_Backend_Not_Inlined_Subprogram --
747 ---------------------------------------------
748
749 procedure Register_Backend_Not_Inlined_Subprogram (Subp : Entity_Id) is
750 begin
21c51f53 751 Append_New_Elmt (Subp, To => Backend_Not_Inlined_Subps);
6c26bac2
AC
752 end Register_Backend_Not_Inlined_Subprogram;
753
fbf5a39b
AC
754 -- Start of processing for Add_Inlined_Subprogram
755
38cbfe40 756 begin
4b96d386
EB
757 -- We can inline the subprogram if its unit is known to be inlined or is
758 -- an instance whose body will be analyzed anyway or the subprogram was
759 -- generated as a body by the compiler (for example an initialization
760 -- procedure) or its declaration was provided along with the body (for
761 -- example an expression function) and it does not declare types with
762 -- nontrivial initialization procedures.
763
764 if (Is_Inlined (Pack)
765 or else Is_Generic_Instance (Pack)
766 or else Nkind (Decl) = N_Subprogram_Body
767 or else Present (Corresponding_Body (Decl)))
38cbfe40
RK
768 and then not Has_Initialized_Type (E)
769 then
71ff3d18 770 Register_Backend_Inlined_Subprogram (E);
fbf5a39b 771
71ff3d18
AC
772 if No (Last_Inlined) then
773 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
38cbfe40 774 else
71ff3d18 775 Set_Next_Inlined_Subprogram (Last_Inlined, E);
fbf5a39b 776 end if;
71ff3d18
AC
777
778 Last_Inlined := E;
3c756b76 779
6c26bac2
AC
780 else
781 Register_Backend_Not_Inlined_Subprogram (E);
38cbfe40 782 end if;
38cbfe40
RK
783 end Add_Inlined_Subprogram;
784
49209838
EB
785 --------------------------------
786 -- Add_Pending_Instantiation --
787 --------------------------------
788
0c1d2675
EB
789 procedure Add_Pending_Instantiation
790 (Inst : Node_Id;
791 Act_Decl : Node_Id;
792 Fin_Scop : Node_Id := Empty)
793 is
4b96d386
EB
794 Act_Decl_Id : Entity_Id;
795 Index : Int;
796
49209838 797 begin
4b96d386
EB
798 -- Here is a defense against a ludicrous number of instantiations
799 -- caused by a circular set of instantiation attempts.
800
f0539a79 801 if Pending_Instantiations.Last + 1 >= Maximum_Instantiations then
4b96d386
EB
802 Error_Msg_Uint_1 := UI_From_Int (Maximum_Instantiations);
803 Error_Msg_N ("too many instantiations, exceeds max of^", Inst);
804 Error_Msg_N ("\limit can be changed using -gnateinn switch", Inst);
805 raise Unrecoverable_Error;
806 end if;
807
49209838
EB
808 -- Capture the body of the generic instantiation along with its context
809 -- for later processing by Instantiate_Bodies.
810
811 Pending_Instantiations.Append
0c1d2675
EB
812 ((Inst_Node => Inst,
813 Act_Decl => Act_Decl,
814 Fin_Scop => Fin_Scop,
49209838
EB
815 Config_Switches => Save_Config_Switches,
816 Current_Sem_Unit => Current_Sem_Unit,
817 Expander_Status => Expander_Active,
49209838
EB
818 Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
819 Scope_Suppress => Scope_Suppress,
820 Warnings => Save_Warnings));
4b96d386
EB
821
822 -- With back-end inlining, also associate the index to the instantiation
823
824 if Back_End_Inlining then
825 Act_Decl_Id := Defining_Entity (Act_Decl);
826 Index := Pending_Instantiations.Last;
827
828 To_Pending_Instantiations.Set (Act_Decl, Index);
829
6c87c83b
EB
830 -- If an instantiation is in the main unit or subunit, or is a nested
831 -- subprogram, then its body is needed as per the analysis done in
832 -- Analyze_Package_Instantiation & Analyze_Subprogram_Instantiation.
4b96d386 833
6c87c83b 834 if In_Main_Unit_Or_Subunit (Act_Decl_Id)
4b96d386
EB
835 or else (Is_Subprogram (Act_Decl_Id)
836 and then Is_Nested (Act_Decl_Id))
837 then
838 Called_Pending_Instantiations.Append (Index);
839
840 Set_Is_Called (Act_Decl_Id);
841 end if;
842 end if;
49209838
EB
843 end Add_Pending_Instantiation;
844
38cbfe40
RK
845 ------------------------
846 -- Add_Scope_To_Clean --
847 ------------------------
848
0c1d2675 849 procedure Add_Scope_To_Clean (Scop : Entity_Id) is
38cbfe40 850 begin
8af95ac6 851 Append_Unique_Elmt (Scop, To_Clean);
38cbfe40
RK
852 end Add_Scope_To_Clean;
853
854 --------------
855 -- Add_Subp --
856 --------------
857
858 function Add_Subp (E : Entity_Id) return Subp_Index is
859 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
860 J : Subp_Index;
861
862 procedure New_Entry;
9de61fcb 863 -- Initialize entry in Inlined table
38cbfe40
RK
864
865 procedure New_Entry is
866 begin
867 Inlined.Increment_Last;
868 Inlined.Table (Inlined.Last).Name := E;
8a49a499 869 Inlined.Table (Inlined.Last).Next := No_Subp;
38cbfe40 870 Inlined.Table (Inlined.Last).First_Succ := No_Succ;
38cbfe40 871 Inlined.Table (Inlined.Last).Main_Call := False;
8a49a499 872 Inlined.Table (Inlined.Last).Processed := False;
38cbfe40
RK
873 end New_Entry;
874
875 -- Start of processing for Add_Subp
876
877 begin
878 if Hash_Headers (Index) = No_Subp then
879 New_Entry;
880 Hash_Headers (Index) := Inlined.Last;
881 return Inlined.Last;
882
883 else
884 J := Hash_Headers (Index);
38cbfe40 885 while J /= No_Subp loop
38cbfe40
RK
886 if Inlined.Table (J).Name = E then
887 return J;
888 else
889 Index := J;
890 J := Inlined.Table (J).Next;
891 end if;
892 end loop;
893
894 -- On exit, subprogram was not found. Enter in table. Index is
895 -- the current last entry on the hash chain.
896
897 New_Entry;
898 Inlined.Table (Index).Next := Inlined.Last;
899 return Inlined.Last;
900 end if;
901 end Add_Subp;
902
903 ----------------------------
904 -- Analyze_Inlined_Bodies --
905 ----------------------------
906
907 procedure Analyze_Inlined_Bodies is
908 Comp_Unit : Node_Id;
8af95ac6 909 J : Nat;
38cbfe40 910 Pack : Entity_Id;
8a49a499 911 Subp : Subp_Index;
38cbfe40
RK
912 S : Succ_Index;
913
8a49a499
AC
914 type Pending_Index is new Nat;
915
916 package Pending_Inlined is new Table.Table (
917 Table_Component_Type => Subp_Index,
918 Table_Index_Type => Pending_Index,
919 Table_Low_Bound => 1,
920 Table_Initial => Alloc.Inlined_Initial,
921 Table_Increment => Alloc.Inlined_Increment,
922 Table_Name => "Pending_Inlined");
923 -- The workpile used to compute the transitive closure
924
84f4072a 925 -- Start of processing for Analyze_Inlined_Bodies
1237d6ef 926
38cbfe40 927 begin
07fc65c4 928 if Serious_Errors_Detected = 0 then
a99ada67 929 Push_Scope (Standard_Standard);
38cbfe40
RK
930
931 J := 0;
932 while J <= Inlined_Bodies.Last
07fc65c4 933 and then Serious_Errors_Detected = 0
38cbfe40
RK
934 loop
935 Pack := Inlined_Bodies.Table (J);
38cbfe40
RK
936 while Present (Pack)
937 and then Scope (Pack) /= Standard_Standard
938 and then not Is_Child_Unit (Pack)
939 loop
940 Pack := Scope (Pack);
941 end loop;
942
943 Comp_Unit := Parent (Pack);
38cbfe40
RK
944 while Present (Comp_Unit)
945 and then Nkind (Comp_Unit) /= N_Compilation_Unit
946 loop
947 Comp_Unit := Parent (Comp_Unit);
948 end loop;
949
b03d3f73
AC
950 -- Load the body if it exists and contains inlineable entities,
951 -- unless it is the main unit, or is an instance whose body has
952 -- already been analyzed.
07fc65c4 953
38cbfe40
RK
954 if Present (Comp_Unit)
955 and then Comp_Unit /= Cunit (Main_Unit)
956 and then Body_Required (Comp_Unit)
2bb988bb
AC
957 and then
958 (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
959 or else
960 (No (Corresponding_Body (Unit (Comp_Unit)))
961 and then Body_Needed_For_Inlining
962 (Defining_Entity (Unit (Comp_Unit)))))
38cbfe40
RK
963 then
964 declare
965 Bname : constant Unit_Name_Type :=
966 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
967
968 OK : Boolean;
969
970 begin
971 if not Is_Loaded (Bname) then
1237d6ef 972 Style_Check := False;
d3271136 973 Load_Needed_Body (Comp_Unit, OK);
38cbfe40
RK
974
975 if not OK then
46ff89f3
AC
976
977 -- Warn that a body was not available for inlining
978 -- by the back-end.
979
38cbfe40
RK
980 Error_Msg_Unit_1 := Bname;
981 Error_Msg_N
685bc70f 982 ("one or more inlined subprograms accessed in $!??",
38cbfe40 983 Comp_Unit);
a99ada67 984 Error_Msg_File_1 :=
38cbfe40 985 Get_File_Name (Bname, Subunit => False);
685bc70f 986 Error_Msg_N ("\but file{ was not found!??", Comp_Unit);
38cbfe40
RK
987 end if;
988 end if;
989 end;
990 end if;
991
992 J := J + 1;
38cbfe40 993
04e9213d
AC
994 if J > Inlined_Bodies.Last then
995
996 -- The analysis of required bodies may have produced additional
997 -- generic instantiations. To obtain further inlining, we need
998 -- to perform another round of generic body instantiations.
999
1000 Instantiate_Bodies;
38cbfe40 1001
04e9213d
AC
1002 -- Symmetrically, the instantiation of required generic bodies
1003 -- may have caused additional bodies to be inlined. To obtain
1004 -- further inlining, we keep looping over the inlined bodies.
1005 end if;
1006 end loop;
38cbfe40 1007
1237d6ef 1008 -- The list of inlined subprograms is an overestimate, because it
6c0f367b
EB
1009 -- includes inlined subprograms called from subprograms that are
1010 -- declared in an inlined package, but are not themselves called.
1011 -- An accurate computation of just those subprograms that are needed
1237d6ef 1012 -- requires that we perform a transitive closure over the call graph,
4ef36ac7 1013 -- starting from calls in the main compilation unit.
38cbfe40
RK
1014
1015 for Index in Inlined.First .. Inlined.Last loop
8a49a499 1016 if not Is_Called (Inlined.Table (Index).Name) then
5b5b27ad 1017
8a49a499
AC
1018 -- This means that Add_Inlined_Body added the subprogram to the
1019 -- table but wasn't able to handle its code unit. Do nothing.
1020
053cf994 1021 Inlined.Table (Index).Processed := True;
5b5b27ad 1022
8a49a499
AC
1023 elsif Inlined.Table (Index).Main_Call then
1024 Pending_Inlined.Increment_Last;
1025 Pending_Inlined.Table (Pending_Inlined.Last) := Index;
1026 Inlined.Table (Index).Processed := True;
5b5b27ad 1027
8a49a499 1028 else
38cbfe40 1029 Set_Is_Called (Inlined.Table (Index).Name, False);
38cbfe40
RK
1030 end if;
1031 end loop;
1032
8a49a499
AC
1033 -- Iterate over the workpile until it is emptied, propagating the
1034 -- Is_Called flag to the successors of the processed subprogram.
38cbfe40 1035
8a49a499
AC
1036 while Pending_Inlined.Last >= Pending_Inlined.First loop
1037 Subp := Pending_Inlined.Table (Pending_Inlined.Last);
1038 Pending_Inlined.Decrement_Last;
38cbfe40 1039
8a49a499
AC
1040 S := Inlined.Table (Subp).First_Succ;
1041
1042 while S /= No_Succ loop
1043 Subp := Successors.Table (S).Subp;
8a49a499
AC
1044
1045 if not Inlined.Table (Subp).Processed then
053cf994 1046 Set_Is_Called (Inlined.Table (Subp).Name);
8a49a499
AC
1047 Pending_Inlined.Increment_Last;
1048 Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
1049 Inlined.Table (Subp).Processed := True;
1050 end if;
1051
1052 S := Successors.Table (S).Next;
1053 end loop;
38cbfe40
RK
1054 end loop;
1055
8a49a499
AC
1056 -- Finally add the called subprograms to the list of inlined
1057 -- subprograms for the unit.
38cbfe40
RK
1058
1059 for Index in Inlined.First .. Inlined.Last loop
be6bb3fc
RK
1060 declare
1061 E : constant Subprogram_Kind_Id := Inlined.Table (Index).Name;
1062
1063 begin
1064 if Is_Called (E) and then not Is_Ignored_Ghost_Entity (E) then
1065 Add_Inlined_Subprogram (E);
1066 end if;
1067 end;
38cbfe40
RK
1068 end loop;
1069
1070 Pop_Scope;
1071 end if;
1072 end Analyze_Inlined_Bodies;
1073
540d8610
ES
1074 --------------------------
1075 -- Build_Body_To_Inline --
1076 --------------------------
38cbfe40 1077
16b10ccc
AC
1078 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
1079 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
540d8610
ES
1080 Original_Body : Node_Id;
1081 Body_To_Analyze : Node_Id;
1082 Max_Size : constant := 10;
540d8610 1083
d42dc0ad
YM
1084 function Has_Extended_Return return Boolean;
1085 -- This function returns True if the subprogram has an extended return
1086 -- statement.
1087
540d8610 1088 function Has_Pending_Instantiation return Boolean;
3f80a182
AC
1089 -- If some enclosing body contains instantiations that appear before
1090 -- the corresponding generic body, the enclosing body has a freeze node
1091 -- so that it can be elaborated after the generic itself. This might
540d8610
ES
1092 -- conflict with subsequent inlinings, so that it is unsafe to try to
1093 -- inline in such a case.
1094
540d8610
ES
1095 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean;
1096 -- If the body of the subprogram includes a call that returns an
1985767d
HK
1097 -- unconstrained type, the secondary stack is involved, and it is
1098 -- not worth inlining.
d42dc0ad
YM
1099 -------------------------
1100 -- Has_Extended_Return --
1101 -------------------------
1102
1103 function Has_Extended_Return return Boolean is
1104 Body_To_Inline : constant Node_Id := N;
1105
1106 function Check_Return (N : Node_Id) return Traverse_Result;
1107 -- Returns OK on node N if this is not an extended return statement
1108
1109 ------------------
1110 -- Check_Return --
1111 ------------------
1112
1113 function Check_Return (N : Node_Id) return Traverse_Result is
1114 begin
1115 case Nkind (N) is
1116 when N_Extended_Return_Statement =>
1117 return Abandon;
1118
1119 -- Skip locally declared subprogram bodies inside the body to
1120 -- inline, as the return statements inside those do not count.
1121
1122 when N_Subprogram_Body =>
1123 if N = Body_To_Inline then
1124 return OK;
1125 else
1126 return Skip;
1127 end if;
1128
1129 when others =>
1130 return OK;
1131 end case;
1132 end Check_Return;
1133
1134 function Check_All_Returns is new Traverse_Func (Check_Return);
1135
1136 -- Start of processing for Has_Extended_Return
1137
1138 begin
1139 return Check_All_Returns (N) /= OK;
1140 end Has_Extended_Return;
1141
540d8610
ES
1142 -------------------------------
1143 -- Has_Pending_Instantiation --
1144 -------------------------------
38cbfe40 1145
540d8610
ES
1146 function Has_Pending_Instantiation return Boolean is
1147 S : Entity_Id;
38cbfe40 1148
540d8610
ES
1149 begin
1150 S := Current_Scope;
1151 while Present (S) loop
1152 if Is_Compilation_Unit (S)
1153 or else Is_Child_Unit (S)
1154 then
1155 return False;
fbf5a39b 1156
540d8610
ES
1157 elsif Ekind (S) = E_Package
1158 and then Has_Forward_Instantiation (S)
1159 then
1160 return True;
1161 end if;
fbf5a39b 1162
540d8610
ES
1163 S := Scope (S);
1164 end loop;
df3e68b1 1165
540d8610
ES
1166 return False;
1167 end Has_Pending_Instantiation;
38cbfe40 1168
540d8610
ES
1169 --------------------------
1170 -- Uses_Secondary_Stack --
1171 --------------------------
1172
1173 function Uses_Secondary_Stack (Bod : Node_Id) return Boolean is
1174 function Check_Call (N : Node_Id) return Traverse_Result;
1175 -- Look for function calls that return an unconstrained type
1176
1177 ----------------
1178 -- Check_Call --
1179 ----------------
1180
1181 function Check_Call (N : Node_Id) return Traverse_Result is
1182 begin
1183 if Nkind (N) = N_Function_Call
1184 and then Is_Entity_Name (Name (N))
1185 and then Is_Composite_Type (Etype (Entity (Name (N))))
1186 and then not Is_Constrained (Etype (Entity (Name (N))))
1187 then
1188 Cannot_Inline
1189 ("cannot inline & (call returns unconstrained type)?",
16b10ccc 1190 N, Spec_Id);
540d8610
ES
1191 return Abandon;
1192 else
1193 return OK;
38cbfe40 1194 end if;
540d8610
ES
1195 end Check_Call;
1196
1197 function Check_Calls is new Traverse_Func (Check_Call);
1198
1199 begin
1200 return Check_Calls (Bod) = Abandon;
1201 end Uses_Secondary_Stack;
1202
1203 -- Start of processing for Build_Body_To_Inline
1204
1205 begin
1206 -- Return immediately if done already
1207
1208 if Nkind (Decl) = N_Subprogram_Declaration
1209 and then Present (Body_To_Inline (Decl))
1210 then
1211 return;
1212
3ac5f7de
JM
1213 -- Functions that return controlled types cannot currently be inlined
1214 -- because they require secondary stack handling; controlled actions
1215 -- may also interfere in complex ways with inlining.
38cbfe40 1216
16b10ccc
AC
1217 elsif Ekind (Spec_Id) = E_Function
1218 and then Needs_Finalization (Etype (Spec_Id))
540d8610
ES
1219 then
1220 Cannot_Inline
16b10ccc 1221 ("cannot inline & (controlled return type)?", N, Spec_Id);
540d8610
ES
1222 return;
1223 end if;
1224
d7f5bfe4 1225 if Has_Excluded_Declaration (Spec_Id, Declarations (N)) then
540d8610
ES
1226 return;
1227 end if;
1228
1229 if Present (Handled_Statement_Sequence (N)) then
1230 if Present (Exception_Handlers (Handled_Statement_Sequence (N))) then
1231 Cannot_Inline
1232 ("cannot inline& (exception handler)?",
1233 First (Exception_Handlers (Handled_Statement_Sequence (N))),
16b10ccc 1234 Spec_Id);
540d8610 1235 return;
3f80a182 1236
16b10ccc
AC
1237 elsif Has_Excluded_Statement
1238 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
540d8610
ES
1239 then
1240 return;
1241 end if;
1242 end if;
1243
2d180af1
YM
1244 -- We do not inline a subprogram that is too large, unless it is marked
1245 -- Inline_Always or we are in GNATprove mode. This pragma does not
1246 -- suppress the other checks on inlining (forbidden declarations,
1247 -- handlers, etc).
540d8610 1248
16b10ccc
AC
1249 if not (Has_Pragma_Inline_Always (Spec_Id) or else GNATprove_Mode)
1250 and then List_Length
1251 (Statements (Handled_Statement_Sequence (N))) > Max_Size
540d8610 1252 then
16b10ccc 1253 Cannot_Inline ("cannot inline& (body too large)?", N, Spec_Id);
540d8610
ES
1254 return;
1255 end if;
1256
1257 if Has_Pending_Instantiation then
1258 Cannot_Inline
1259 ("cannot inline& (forward instance within enclosing body)?",
16b10ccc 1260 N, Spec_Id);
540d8610
ES
1261 return;
1262 end if;
1263
1264 -- Within an instance, the body to inline must be treated as a nested
1265 -- generic, so that the proper global references are preserved.
1266
1267 -- Note that we do not do this at the library level, because it is not
66f95f60 1268 -- needed, and furthermore this causes trouble if front-end inlining
540d8610
ES
1269 -- is activated (-gnatN).
1270
1271 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1272 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
5e9cb404 1273 Original_Body := Copy_Generic_Node (N, Empty, Instantiating => True);
540d8610
ES
1274 else
1275 Original_Body := Copy_Separate_Tree (N);
1276 end if;
1277
1278 -- We need to capture references to the formals in order to substitute
1279 -- the actuals at the point of inlining, i.e. instantiation. To treat
3f80a182
AC
1280 -- the formals as globals to the body to inline, we nest it within a
1281 -- dummy parameterless subprogram, declared within the real one. To
1282 -- avoid generating an internal name (which is never public, and which
1283 -- affects serial numbers of other generated names), we use an internal
1284 -- symbol that cannot conflict with user declarations.
38cbfe40 1285
540d8610
ES
1286 Set_Parameter_Specifications (Specification (Original_Body), No_List);
1287 Set_Defining_Unit_Name
1288 (Specification (Original_Body),
697b781a 1289 Make_Defining_Identifier (Sloc (N), Name_uParent));
540d8610
ES
1290 Set_Corresponding_Spec (Original_Body, Empty);
1291
3de3a1be 1292 -- Remove all aspects/pragmas that have no meaning in an inlined body
6d0b56ad 1293
697b781a 1294 Remove_Aspects_And_Pragmas (Original_Body);
6d0b56ad 1295
5e9cb404
AC
1296 Body_To_Analyze :=
1297 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
540d8610
ES
1298
1299 -- Set return type of function, which is also global and does not need
1300 -- to be resolved.
1301
16b10ccc 1302 if Ekind (Spec_Id) = E_Function then
697b781a
AC
1303 Set_Result_Definition
1304 (Specification (Body_To_Analyze),
1305 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
540d8610
ES
1306 end if;
1307
1308 if No (Declarations (N)) then
1309 Set_Declarations (N, New_List (Body_To_Analyze));
1310 else
1311 Append (Body_To_Analyze, Declarations (N));
1312 end if;
1313
a714ca80 1314 Start_Generic;
540d8610
ES
1315
1316 Analyze (Body_To_Analyze);
1317 Push_Scope (Defining_Entity (Body_To_Analyze));
1318 Save_Global_References (Original_Body);
1319 End_Scope;
1320 Remove (Body_To_Analyze);
1321
a714ca80 1322 End_Generic;
540d8610
ES
1323
1324 -- Restore environment if previously saved
1325
1326 if In_Instance and then Scope (Current_Scope) /= Standard_Standard then
1327 Restore_Env;
1328 end if;
1329
3ac5f7de
JM
1330 -- Functions that return unconstrained composite types require
1331 -- secondary stack handling, and cannot currently be inlined, unless
1332 -- all return statements return a local variable that is the first
1333 -- local declaration in the body. We had to delay this check until
1334 -- the body of the function is analyzed since Has_Single_Return()
1335 -- requires a minimum decoration.
1336
1337 if Ekind (Spec_Id) = E_Function
1338 and then not Is_Scalar_Type (Etype (Spec_Id))
1339 and then not Is_Access_Type (Etype (Spec_Id))
1340 and then not Is_Constrained (Etype (Spec_Id))
1341 then
1342 if not Has_Single_Return (Body_To_Analyze)
1343
1344 -- Skip inlining if the function returns an unconstrained type
1345 -- using an extended return statement, since this part of the
1346 -- new inlining model is not yet supported by the current
0964be07 1347 -- implementation.
3ac5f7de
JM
1348
1349 or else (Returns_Unconstrained_Type (Spec_Id)
1350 and then Has_Extended_Return)
1351 then
1352 Cannot_Inline
1353 ("cannot inline & (unconstrained return type)?", N, Spec_Id);
1354 return;
1355 end if;
1356
43478196 1357 -- If secondary stack is used, there is no point in inlining. We have
540d8610
ES
1358 -- already issued the warning in this case, so nothing to do.
1359
3ac5f7de 1360 elsif Uses_Secondary_Stack (Body_To_Analyze) then
540d8610
ES
1361 return;
1362 end if;
1363
1364 Set_Body_To_Inline (Decl, Original_Body);
2e02ab86 1365 Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
16b10ccc 1366 Set_Is_Inlined (Spec_Id);
540d8610
ES
1367 end Build_Body_To_Inline;
1368
3de3a1be
YM
1369 -------------------------------------------
1370 -- Call_Can_Be_Inlined_In_GNATprove_Mode --
1371 -------------------------------------------
1372
1373 function Call_Can_Be_Inlined_In_GNATprove_Mode
42edc837
PT
1374 (N : Node_Id;
1375 Subp : Entity_Id) return Boolean
3de3a1be 1376 is
cdf15b4b
YM
1377 function Has_Dereference (N : Node_Id) return Boolean;
1378 -- Return whether N contains an explicit dereference
1379
1380 ---------------------
1381 -- Has_Dereference --
1382 ---------------------
1383
1384 function Has_Dereference (N : Node_Id) return Boolean is
1385
1386 function Process (N : Node_Id) return Traverse_Result;
1387 -- Process one node in search for dereference
1388
1389 -------------
1390 -- Process --
1391 -------------
1392
1393 function Process (N : Node_Id) return Traverse_Result is
1394 begin
1395 if Nkind (N) = N_Explicit_Dereference then
1396 return Abandon;
1397 else
1398 return OK;
1399 end if;
1400 end Process;
1401
1402 function Traverse is new Traverse_Func (Process);
1403 -- Traverse tree to look for dereference
1404
1405 begin
1406 return Traverse (N) = Abandon;
1407 end Has_Dereference;
1408
1409 -- Local variables
1410
3de3a1be
YM
1411 F : Entity_Id;
1412 A : Node_Id;
1413
1414 begin
cdf15b4b
YM
1415 -- Check if inlining may lead to missing a check on type conversion of
1416 -- input parameters otherwise.
1417
3de3a1be
YM
1418 F := First_Formal (Subp);
1419 A := First_Actual (N);
1420 while Present (F) loop
1421 if Ekind (F) /= E_Out_Parameter
1422 and then not Same_Type (Etype (F), Etype (A))
1423 and then
1424 (Is_By_Reference_Type (Etype (A))
da9683f4 1425 or else Is_Limited_Type (Etype (A)))
3de3a1be
YM
1426 then
1427 return False;
1428 end if;
1429
1430 Next_Formal (F);
1431 Next_Actual (A);
1432 end loop;
1433
cdf15b4b
YM
1434 -- Check if inlining may lead to introducing temporaries of access type,
1435 -- which can lead to missing checks for memory leaks. This can only
1436 -- come from an (IN-)OUT parameter transformed into a renaming by SPARK
1437 -- expansion, whose side-effects are removed, and a dereference in the
1438 -- corresponding actual. If the formal itself is of a deep type (it has
1439 -- access subcomponents), the subprogram already cannot be inlined in
1440 -- GNATprove mode.
1441
1442 F := First_Formal (Subp);
1443 A := First_Actual (N);
1444 while Present (F) loop
1445 if Ekind (F) /= E_In_Parameter
1446 and then Has_Dereference (A)
1447 then
1448 return False;
1449 end if;
1450
1451 Next_Formal (F);
1452 Next_Actual (A);
1453 end loop;
1454
3de3a1be
YM
1455 return True;
1456 end Call_Can_Be_Inlined_In_GNATprove_Mode;
1457
2d180af1
YM
1458 --------------------------------------
1459 -- Can_Be_Inlined_In_GNATprove_Mode --
1460 --------------------------------------
1461
1462 function Can_Be_Inlined_In_GNATprove_Mode
1463 (Spec_Id : Entity_Id;
1464 Body_Id : Entity_Id) return Boolean
1465 is
df9d6153
YM
1466 function Has_Constant_With_Address_Clause
1467 (Body_Node : Node_Id)
1468 return Boolean;
1469 -- Returns true if the subprogram contains a declaration of a constant
1470 -- with an address clause, which could become illegal in SPARK after
1471 -- inlining, if the address clause mentions a constant view of a mutable
1472 -- object at call site.
1473
9d98b6d8
YM
1474 function Has_Formal_Or_Result_Of_Deep_Type
1475 (Id : Entity_Id) return Boolean;
1476 -- Returns true if the subprogram has at least one formal parameter or
1477 -- a return type of a deep type: either an access type or a composite
1478 -- type containing an access type.
1479
36ddd8c0 1480 function Has_Formal_With_Per_Object_Constrained_Component
d3ef4bd6 1481 (Id : Entity_Id) return Boolean;
5f6061af 1482 -- Returns true if the subprogram has at least one formal parameter of
57d08392
AC
1483 -- an unconstrained record type with per-object constraints on component
1484 -- types.
d3ef4bd6 1485
53c32e9d
YM
1486 function Has_Hide_Unhide_Annotation
1487 (Spec_Id, Body_Id : Entity_Id)
1488 return Boolean;
1489 -- Returns whether the subprogram has an annotation Hide_Info or
1490 -- Unhide_Info on its spec or body.
1491
2c59b338
YM
1492 function Has_Skip_Proof_Annotation (Id : Entity_Id) return Boolean;
1493 -- Returns True if subprogram Id has an annotation Skip_Proof or
1494 -- Skip_Flow_And_Proof.
1495
2d180af1 1496 function Has_Some_Contract (Id : Entity_Id) return Boolean;
4ac62786
AC
1497 -- Return True if subprogram Id has any contract. The presence of
1498 -- Extensions_Visible or Volatile_Function is also considered as a
1499 -- contract here.
2d180af1 1500
82701811 1501 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean;
4ac62786 1502 -- Return True if subprogram Id defines a compilation unit
82701811 1503
db174c98 1504 function In_Package_Spec (Id : Entity_Id) return Boolean;
4ac62786
AC
1505 -- Return True if subprogram Id is defined in the package specification,
1506 -- either its visible or private part.
2d180af1 1507
231ef54b
YM
1508 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean;
1509 -- Return True if subprogram Id could be a traversal function, as
1510 -- defined in SPARK RM 3.10. This is only a safe approximation, as the
1511 -- knowledge of the SPARK boundary is needed to determine exactly
1512 -- traversal functions.
1513
df9d6153
YM
1514 --------------------------------------
1515 -- Has_Constant_With_Address_Clause --
1516 --------------------------------------
1517
1518 function Has_Constant_With_Address_Clause
1519 (Body_Node : Node_Id)
1520 return Boolean
1521 is
1522 function Check_Constant_With_Addresss_Clause
1523 (N : Node_Id)
1524 return Traverse_Result;
1525 -- Returns Abandon on node N if this is a declaration of a constant
1526 -- object with an address clause.
1527
1528 -----------------------------------------
1529 -- Check_Constant_With_Addresss_Clause --
1530 -----------------------------------------
1531
1532 function Check_Constant_With_Addresss_Clause
1533 (N : Node_Id)
1534 return Traverse_Result
1535 is
1536 begin
1537 case Nkind (N) is
1538 when N_Object_Declaration =>
1539 declare
1540 Obj : constant Entity_Id := Defining_Entity (N);
1541 begin
1542 if Constant_Present (N)
1543 and then
1544 (Present (Address_Clause (Obj))
1545 or else Has_Aspect (Obj, Aspect_Address))
1546 then
1547 return Abandon;
1548 else
1549 return OK;
1550 end if;
1551 end;
1552
1553 -- Skip locally declared subprogram bodies inside the body to
1554 -- inline, as the declarations inside those do not count.
1555
1556 when N_Subprogram_Body =>
1557 if N = Body_Node then
1558 return OK;
1559 else
1560 return Skip;
1561 end if;
1562
1563 when others =>
1564 return OK;
1565 end case;
1566 end Check_Constant_With_Addresss_Clause;
1567
1568 function Check_All_Constants_With_Address_Clause is new
1569 Traverse_Func (Check_Constant_With_Addresss_Clause);
1570
1571 -- Start of processing for Has_Constant_With_Address_Clause
1572
1573 begin
1574 return Check_All_Constants_With_Address_Clause
1575 (Body_Node) = Abandon;
1576 end Has_Constant_With_Address_Clause;
1577
9d98b6d8
YM
1578 ---------------------------------------
1579 -- Has_Formal_Or_Result_Of_Deep_Type --
1580 ---------------------------------------
1581
1582 function Has_Formal_Or_Result_Of_Deep_Type
1583 (Id : Entity_Id) return Boolean
1584 is
1585 function Is_Deep (Typ : Entity_Id) return Boolean;
1586 -- Return True if Typ is deep: either an access type or a composite
1587 -- type containing an access type.
1588
1589 -------------
1590 -- Is_Deep --
1591 -------------
1592
1593 function Is_Deep (Typ : Entity_Id) return Boolean is
1594 begin
1595 case Type_Kind'(Ekind (Typ)) is
1596 when Access_Kind =>
1597 return True;
1598
1599 when E_Array_Type
1600 | E_Array_Subtype
1601 =>
1602 return Is_Deep (Component_Type (Typ));
1603
1604 when Record_Kind =>
1605 declare
1606 Comp : Entity_Id := First_Component_Or_Discriminant (Typ);
1607 begin
1608 while Present (Comp) loop
1609 if Is_Deep (Etype (Comp)) then
1610 return True;
1611 end if;
1612 Next_Component_Or_Discriminant (Comp);
1613 end loop;
1614 end;
1615 return False;
1616
1617 when Scalar_Kind
1618 | E_String_Literal_Subtype
1619 | Concurrent_Kind
1620 | Incomplete_Kind
1621 | E_Exception_Type
1622 | E_Subprogram_Type
1623 =>
1624 return False;
1625
1626 when E_Private_Type
1627 | E_Private_Subtype
1628 | E_Limited_Private_Type
1629 | E_Limited_Private_Subtype
1630 =>
1631 -- Conservatively consider that the type might be deep if
1632 -- its completion has not been seen yet.
1633
1634 if No (Underlying_Type (Typ)) then
1635 return True;
5913d1b7
YM
1636
1637 -- Do not peek under a private type if its completion has
1638 -- SPARK_Mode Off. In such a case, a deep type is considered
1639 -- by GNATprove to be not deep.
1640
1641 elsif Present (Full_View (Typ))
1642 and then Present (SPARK_Pragma (Full_View (Typ)))
1643 and then Get_SPARK_Mode_From_Annotation
1644 (SPARK_Pragma (Full_View (Typ))) = Off
1645 then
1646 return False;
1647
1648 -- Otherwise peek under the private type.
1649
9d98b6d8
YM
1650 else
1651 return Is_Deep (Underlying_Type (Typ));
1652 end if;
1653 end case;
1654 end Is_Deep;
1655
1656 -- Local variables
1657
1658 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1659 Formal : Entity_Id;
1660 Formal_Typ : Entity_Id;
1661
1662 -- Start of processing for Has_Formal_Or_Result_Of_Deep_Type
1663
1664 begin
1665 -- Inspect all parameters of the subprogram looking for a formal
1666 -- of a deep type.
1667
1668 Formal := First_Formal (Subp_Id);
1669 while Present (Formal) loop
1670 Formal_Typ := Etype (Formal);
1671
1672 if Is_Deep (Formal_Typ) then
1673 return True;
1674 end if;
1675
1676 Next_Formal (Formal);
1677 end loop;
1678
1679 -- Check whether this is a function whose return type is deep
1680
1681 if Ekind (Subp_Id) = E_Function
1682 and then Is_Deep (Etype (Subp_Id))
1683 then
1684 return True;
1685 end if;
1686
1687 return False;
1688 end Has_Formal_Or_Result_Of_Deep_Type;
1689
36ddd8c0
PT
1690 ------------------------------------------------------
1691 -- Has_Formal_With_Per_Object_Constrained_Component --
1692 ------------------------------------------------------
d3ef4bd6 1693
36ddd8c0 1694 function Has_Formal_With_Per_Object_Constrained_Component
4ac62786
AC
1695 (Id : Entity_Id) return Boolean
1696 is
36ddd8c0 1697 function Has_Per_Object_Constrained_Component
57d08392 1698 (Typ : Entity_Id) return Boolean;
4ac62786
AC
1699 -- Determine whether unconstrained record type Typ has at least one
1700 -- component that depends on a discriminant.
d3ef4bd6 1701
57d08392 1702 ------------------------------------------
36ddd8c0 1703 -- Has_Per_Object_Constrained_Component --
57d08392 1704 ------------------------------------------
d3ef4bd6 1705
36ddd8c0 1706 function Has_Per_Object_Constrained_Component
57d08392
AC
1707 (Typ : Entity_Id) return Boolean
1708 is
1709 Comp : Entity_Id;
d3ef4bd6 1710
57d08392 1711 begin
4ac62786
AC
1712 -- Inspect all components of the record type looking for one that
1713 -- depends on a discriminant.
d3ef4bd6 1714
57d08392
AC
1715 Comp := First_Component (Typ);
1716 while Present (Comp) loop
36ddd8c0 1717 if Has_Per_Object_Constraint (Comp) then
57d08392
AC
1718 return True;
1719 end if;
d3ef4bd6 1720
57d08392
AC
1721 Next_Component (Comp);
1722 end loop;
1723
1724 return False;
36ddd8c0 1725 end Has_Per_Object_Constrained_Component;
d3ef4bd6 1726
57d08392 1727 -- Local variables
d3ef4bd6 1728
57d08392
AC
1729 Subp_Id : constant Entity_Id := Ultimate_Alias (Id);
1730 Formal : Entity_Id;
1731 Formal_Typ : Entity_Id;
d3ef4bd6 1732
3de3a1be 1733 -- Start of processing for
36ddd8c0 1734 -- Has_Formal_With_Per_Object_Constrained_Component
d3ef4bd6 1735
57d08392
AC
1736 begin
1737 -- Inspect all parameters of the subprogram looking for a formal
1738 -- of an unconstrained record type with at least one discriminant
1739 -- dependent component.
1740
1741 Formal := First_Formal (Subp_Id);
1742 while Present (Formal) loop
1743 Formal_Typ := Etype (Formal);
d3ef4bd6 1744
57d08392
AC
1745 if Is_Record_Type (Formal_Typ)
1746 and then not Is_Constrained (Formal_Typ)
36ddd8c0 1747 and then Has_Per_Object_Constrained_Component (Formal_Typ)
57d08392
AC
1748 then
1749 return True;
d3ef4bd6 1750 end if;
57d08392
AC
1751
1752 Next_Formal (Formal);
1753 end loop;
d3ef4bd6
AC
1754
1755 return False;
36ddd8c0 1756 end Has_Formal_With_Per_Object_Constrained_Component;
d3ef4bd6 1757
53c32e9d
YM
1758 --------------------------------
1759 -- Has_Hide_Unhide_Annotation --
1760 --------------------------------
1761
1762 function Has_Hide_Unhide_Annotation
1763 (Spec_Id, Body_Id : Entity_Id)
1764 return Boolean
1765 is
1766 function Has_Hide_Unhide_Pragma (Prag : Node_Id) return Boolean;
1767 -- Return whether a pragma Hide/Unhide is present in the list of
1768 -- pragmas starting with Prag.
1769
1770 ----------------------------
1771 -- Has_Hide_Unhide_Pragma --
1772 ----------------------------
1773
1774 function Has_Hide_Unhide_Pragma (Prag : Node_Id) return Boolean is
1775 Decl : Node_Id := Prag;
1776 begin
1777 while Present (Decl)
1778 and then Nkind (Decl) = N_Pragma
1779 loop
1780 if Get_Pragma_Id (Decl) = Pragma_Annotate
1781 and then List_Length (Pragma_Argument_Associations (Decl)) = 4
1782 then
1783 declare
1784 Arg1 : constant Node_Id :=
1785 First (Pragma_Argument_Associations (Decl));
1786 Arg2 : constant Node_Id := Next (Arg1);
1787 Arg1_Name : constant Name_Id :=
1788 Chars (Get_Pragma_Arg (Arg1));
1789 Arg2_Name : constant String :=
1790 Get_Name_String (Chars (Get_Pragma_Arg (Arg2)));
1791 begin
1792 if Arg1_Name = Name_Gnatprove
1793 and then Arg2_Name in "hide_info" | "unhide_info"
1794 then
1795 return True;
1796 end if;
1797 end;
1798 end if;
1799
1800 Next (Decl);
1801 end loop;
1802
1803 return False;
1804 end Has_Hide_Unhide_Pragma;
1805
1806 begin
1807 if Present (Spec_Id)
bd2462a8 1808 and then Is_List_Member (Unit_Declaration_Node (Spec_Id))
53c32e9d
YM
1809 and then Has_Hide_Unhide_Pragma
1810 (Next (Unit_Declaration_Node (Spec_Id)))
1811 then
1812 return True;
1813
1814 elsif Present (Body_Id) then
1815 declare
1816 Subp_Body : constant N_Subprogram_Body_Id :=
1817 Unit_Declaration_Node (Body_Id);
1818 begin
bd2462a8
YM
1819 return
1820 (Is_List_Member (Subp_Body)
1821 and then Has_Hide_Unhide_Pragma (Next (Subp_Body)))
53c32e9d
YM
1822 or else
1823 Has_Hide_Unhide_Pragma (First (Declarations (Subp_Body)));
1824 end;
1825
1826 else
1827 return False;
1828 end if;
1829 end Has_Hide_Unhide_Annotation;
1830
2c59b338
YM
1831 -------------------------------
1832 -- Has_Skip_Proof_Annotation --
1833 -------------------------------
1834
1835 function Has_Skip_Proof_Annotation (Id : Entity_Id) return Boolean is
1836 Decl : Node_Id := Unit_Declaration_Node (Id);
1837
1838 begin
1839 Next (Decl);
1840
1841 while Present (Decl)
1842 and then Nkind (Decl) = N_Pragma
1843 loop
1844 if Get_Pragma_Id (Decl) = Pragma_Annotate
1845 and then List_Length (Pragma_Argument_Associations (Decl)) = 3
1846 then
1847 declare
1848 Arg1 : constant Node_Id :=
1849 First (Pragma_Argument_Associations (Decl));
1850 Arg2 : constant Node_Id := Next (Arg1);
53c32e9d
YM
1851 Arg1_Name : constant Name_Id :=
1852 Chars (Get_Pragma_Arg (Arg1));
2c59b338
YM
1853 Arg2_Name : constant String :=
1854 Get_Name_String (Chars (Get_Pragma_Arg (Arg2)));
1855 begin
53c32e9d 1856 if Arg1_Name = Name_Gnatprove
2c59b338
YM
1857 and then Arg2_Name in "skip_proof" | "skip_flow_and_proof"
1858 then
1859 return True;
1860 end if;
1861 end;
1862 end if;
1863
1864 Next (Decl);
1865 end loop;
1866
1867 return False;
1868 end Has_Skip_Proof_Annotation;
1869
2d180af1
YM
1870 -----------------------
1871 -- Has_Some_Contract --
1872 -----------------------
1873
1874 function Has_Some_Contract (Id : Entity_Id) return Boolean is
a98480dd
AC
1875 Items : Node_Id;
1876
2d180af1 1877 begin
a98480dd
AC
1878 -- A call to an expression function may precede the actual body which
1879 -- is inserted at the end of the enclosing declarations. Ensure that
c05ba1f1 1880 -- the related entity is decorated before inspecting the contract.
a98480dd 1881
c05ba1f1 1882 if Is_Subprogram_Or_Generic_Subprogram (Id) then
a98480dd
AC
1883 Items := Contract (Id);
1884
b276ab7a
AC
1885 -- Note that Classifications is not Empty when Extensions_Visible
1886 -- or Volatile_Function is present, which causes such subprograms
1887 -- to be considered to have a contract here. This is fine as we
1888 -- want to avoid inlining these too.
1889
a98480dd
AC
1890 return Present (Items)
1891 and then (Present (Pre_Post_Conditions (Items)) or else
1892 Present (Contract_Test_Cases (Items)) or else
1893 Present (Classifications (Items)));
1894 end if;
1895
1896 return False;
2d180af1
YM
1897 end Has_Some_Contract;
1898
63a5b3dc
AC
1899 ---------------------
1900 -- In_Package_Spec --
1901 ---------------------
2d180af1 1902
db174c98 1903 function In_Package_Spec (Id : Entity_Id) return Boolean is
63a5b3dc
AC
1904 P : constant Node_Id := Parent (Subprogram_Spec (Id));
1905 -- Parent of the subprogram's declaration
fc27e20e 1906
2d180af1 1907 begin
63a5b3dc
AC
1908 return Nkind (Enclosing_Declaration (P)) = N_Package_Declaration;
1909 end In_Package_Spec;
2d180af1 1910
82701811
AC
1911 ------------------------
1912 -- Is_Unit_Subprogram --
1913 ------------------------
1914
1915 function Is_Unit_Subprogram (Id : Entity_Id) return Boolean is
1916 Decl : Node_Id := Parent (Parent (Id));
1917 begin
1918 if Nkind (Parent (Id)) = N_Defining_Program_Unit_Name then
1919 Decl := Parent (Decl);
1920 end if;
1921
1922 return Nkind (Parent (Decl)) = N_Compilation_Unit;
1923 end Is_Unit_Subprogram;
1924
231ef54b
YM
1925 ------------------------------
1926 -- Maybe_Traversal_Function --
1927 ------------------------------
1928
1929 function Maybe_Traversal_Function (Id : Entity_Id) return Boolean is
1930 begin
1931 return Ekind (Id) = E_Function
1932
1933 -- Only traversal functions return an anonymous access-to-object
1934 -- type in SPARK.
1935
1936 and then Is_Anonymous_Access_Type (Etype (Id));
1937 end Maybe_Traversal_Function;
1938
fc27e20e
RD
1939 -- Local declarations
1940
da9683f4
AC
1941 Id : Entity_Id;
1942 -- Procedure or function entity for the subprogram
2d180af1 1943
704228bd 1944 -- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
2d180af1
YM
1945
1946 begin
4bd4bb7f
AC
1947 pragma Assert (Present (Spec_Id) or else Present (Body_Id));
1948
2d180af1
YM
1949 if Present (Spec_Id) then
1950 Id := Spec_Id;
1951 else
1952 Id := Body_Id;
1953 end if;
1954
52c1498c
YM
1955 -- Only local subprograms without contracts are inlined in GNATprove
1956 -- mode, as these are the subprograms which a user is not interested in
1957 -- analyzing in isolation, but rather in the context of their call. This
1958 -- is a convenient convention, that could be changed for an explicit
1959 -- pragma/aspect one day.
1960
1961 -- In a number of special cases, inlining is not desirable or not
1962 -- possible, see below.
1399d355 1963
2d180af1
YM
1964 -- Do not inline unit-level subprograms
1965
82701811 1966 if Is_Unit_Subprogram (Id) then
2d180af1
YM
1967 return False;
1968
63a5b3dc
AC
1969 -- Do not inline subprograms declared in package specs, because they are
1970 -- not local, i.e. can be called either from anywhere (if declared in
1971 -- visible part) or from the child units (if declared in private part).
2d180af1 1972
63a5b3dc 1973 elsif In_Package_Spec (Id) then
2d180af1
YM
1974 return False;
1975
9fb1e654
AC
1976 -- Do not inline subprograms declared in other units. This is important
1977 -- in particular for subprograms defined in the private part of a
1978 -- package spec, when analyzing one of its child packages, as otherwise
1979 -- we issue spurious messages about the impossibility to inline such
1980 -- calls.
1981
1982 elsif not In_Extended_Main_Code_Unit (Id) then
1983 return False;
1984
cbb0b553
YM
1985 -- Do not inline dispatching operations, as only their static calls
1986 -- can be analyzed in context, and not their dispatching calls.
1987
1988 elsif Is_Dispatching_Operation (Id) then
1989 return False;
1990
7188885e
AC
1991 -- Do not inline subprograms marked No_Return, possibly used for
1992 -- signaling errors, which GNATprove handles specially.
1993
1994 elsif No_Return (Id) then
1995 return False;
1996
2d180af1 1997 -- Do not inline subprograms that have a contract on the spec or the
b276ab7a
AC
1998 -- body. Use the contract(s) instead in GNATprove. This also prevents
1999 -- inlining of subprograms with Extensions_Visible or Volatile_Function.
2d180af1
YM
2000
2001 elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id))
4bd4bb7f
AC
2002 or else
2003 (Present (Body_Id) and then Has_Some_Contract (Body_Id))
2d180af1
YM
2004 then
2005 return False;
2006
52c1498c
YM
2007 -- Do not inline expression functions, which are directly inlined at the
2008 -- prover level.
2d180af1
YM
2009
2010 elsif (Present (Spec_Id) and then Is_Expression_Function (Spec_Id))
4bd4bb7f
AC
2011 or else
2012 (Present (Body_Id) and then Is_Expression_Function (Body_Id))
2d180af1
YM
2013 then
2014 return False;
2015
52c1498c
YM
2016 -- Do not inline generic subprogram instances. The visibility rules of
2017 -- generic instances plays badly with inlining.
1399d355 2018
ac072cb2
AC
2019 elsif Is_Generic_Instance (Spec_Id) then
2020 return False;
2021
2178830b
AC
2022 -- Only inline subprograms whose spec is marked SPARK_Mode On. For
2023 -- the subprogram body, a similar check is performed after the body
2024 -- is analyzed, as this is where a pragma SPARK_Mode might be inserted.
2025
2026 elsif Present (Spec_Id)
eb1ee757
AC
2027 and then
2028 (No (SPARK_Pragma (Spec_Id))
933aa0ac
AC
2029 or else
2030 Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
2d180af1
YM
2031 then
2032 return False;
2033
a9e6f868
YM
2034 -- Do not inline subprograms and entries defined inside protected types,
2035 -- which typically are not helper subprograms, which also avoids getting
2036 -- spurious messages on calls that cannot be inlined.
2037
66f95f60 2038 elsif Within_Protected_Type (Id) then
a9e6f868
YM
2039 return False;
2040
d3ef4bd6 2041 -- Do not inline predicate functions (treated specially by GNATprove)
2178830b
AC
2042
2043 elsif Is_Predicate_Function (Id) then
2044 return False;
2045
d3ef4bd6
AC
2046 -- Do not inline subprograms with a parameter of an unconstrained
2047 -- record type if it has discrimiant dependent fields. Indeed, with
2048 -- such parameters, the frontend cannot always ensure type compliance
2049 -- in record component accesses (in particular with records containing
2050 -- packed arrays).
2051
36ddd8c0 2052 elsif Has_Formal_With_Per_Object_Constrained_Component (Id) then
d3ef4bd6
AC
2053 return False;
2054
9d98b6d8
YM
2055 -- Do not inline subprograms with a formal parameter or return type of
2056 -- a deep type, as in that case inlining might generate code that
2057 -- violates borrow-checking rules of SPARK 3.10 even if the original
2058 -- code did not.
2059
2060 elsif Has_Formal_Or_Result_Of_Deep_Type (Id) then
2061 return False;
2062
231ef54b
YM
2063 -- Do not inline subprograms which may be traversal functions. Such
2064 -- inlining introduces temporary variables of named access type for
2065 -- which assignments are move instead of borrow/observe, possibly
2066 -- leading to spurious errors when checking SPARK rules related to
2067 -- pointer usage.
2068
2069 elsif Maybe_Traversal_Function (Id) then
2070 return False;
2071
2c59b338
YM
2072 -- Do not inline subprograms with the Skip_Proof or Skip_Flow_And_Proof
2073 -- annotation, which should be handled separately.
2074
2075 elsif Has_Skip_Proof_Annotation (Id) then
2076 return False;
53c32e9d
YM
2077
2078 -- Do not inline subprograms with the Hide_Info or Unhide_Info
2079 -- annotation, since their scope has special visibility on the
2080 -- precise definition of some entities.
2081
2082 elsif Has_Hide_Unhide_Annotation (Spec_Id, Body_Id) then
2083 return False;
2c59b338 2084
df9d6153
YM
2085 -- Do not inline subprograms containing constant declarations with an
2086 -- address clause, as inlining could lead to a spurious violation of
2087 -- SPARK rules.
2088
2089 elsif Present (Body_Id)
2090 and then
2091 Has_Constant_With_Address_Clause (Unit_Declaration_Node (Body_Id))
2092 then
2093 return False;
2094
2d180af1
YM
2095 -- Otherwise, this is a subprogram declared inside the private part of a
2096 -- package, or inside a package body, or locally in a subprogram, and it
2097 -- does not have any contract. Inline it.
2098
2099 else
2100 return True;
2101 end if;
2102 end Can_Be_Inlined_In_GNATprove_Mode;
2103
da9683f4
AC
2104 -------------------
2105 -- Cannot_Inline --
2106 -------------------
2107
2108 procedure Cannot_Inline
3fcb8100
YM
2109 (Msg : String;
2110 N : Node_Id;
2111 Subp : Entity_Id;
2112 Is_Serious : Boolean := False;
2113 Suppress_Info : Boolean := False)
da9683f4 2114 is
73dbf51a
VI
2115 Inline_Prefix : constant String := "cannot inline";
2116
2117 function Starts_With (S, Prefix : String) return Boolean is
2118 (S (S'First .. S'First + Prefix'Length - 1) = Prefix);
2119
da9683f4
AC
2120 begin
2121 -- In GNATprove mode, inlining is the technical means by which the
2122 -- higher-level goal of contextual analysis is reached, so issue
2123 -- messages about failure to apply contextual analysis to a
2124 -- subprogram, rather than failure to inline it.
2125
2126 if GNATprove_Mode
73dbf51a 2127 and then Starts_With (Msg, Inline_Prefix)
da9683f4
AC
2128 then
2129 declare
73dbf51a
VI
2130 Msg_Txt : constant String :=
2131 Msg (Msg'First + Inline_Prefix'Length .. Msg'Last);
da9683f4 2132
73dbf51a
VI
2133 New_Msg : constant String :=
2134 "info: no contextual analysis of" & Msg_Txt;
da9683f4 2135 begin
3fcb8100 2136 Cannot_Inline (New_Msg, N, Subp, Is_Serious, Suppress_Info);
da9683f4
AC
2137 return;
2138 end;
2139 end if;
2140
66f95f60 2141 -- Legacy front-end inlining model
da9683f4
AC
2142
2143 if not Back_End_Inlining then
2144
2145 -- Do not emit warning if this is a predefined unit which is not
2146 -- the main unit. With validity checks enabled, some predefined
2147 -- subprograms may contain nested subprograms and become ineligible
2148 -- for inlining.
2149
8ab31c0c 2150 if Is_Predefined_Unit (Get_Source_Unit (Subp))
da9683f4
AC
2151 and then not In_Extended_Main_Source_Unit (Subp)
2152 then
2153 null;
2154
3fcb8100
YM
2155 -- In GNATprove mode, issue an info message when -gnatd_f is set and
2156 -- Suppress_Info is False, and indicate that the subprogram is not
2157 -- always inlined by setting flag Is_Inlined_Always to False.
da9683f4
AC
2158
2159 elsif GNATprove_Mode then
2160 Set_Is_Inlined_Always (Subp, False);
a30a69c1 2161
3fcb8100 2162 if Debug_Flag_Underscore_F and not Suppress_Info then
940cf495 2163 Error_Msg_NE (Msg, N, Subp);
a30a69c1 2164 end if;
da9683f4
AC
2165
2166 elsif Has_Pragma_Inline_Always (Subp) then
2167
2168 -- Remove last character (question mark) to make this into an
2169 -- error, because the Inline_Always pragma cannot be obeyed.
2170
2171 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2172
2173 elsif Ineffective_Inline_Warnings then
2174 Error_Msg_NE (Msg & "p?", N, Subp);
2175 end if;
2176
66f95f60 2177 -- New semantics relying on back-end inlining
da9683f4
AC
2178
2179 elsif Is_Serious then
2180
2181 -- Remove last character (question mark) to make this into an error.
2182
2183 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2184
da9683f4
AC
2185 else
2186
2187 -- Do not emit warning if this is a predefined unit which is not
2188 -- the main unit. This behavior is currently provided for backward
2189 -- compatibility but it will be removed when we enforce the
2190 -- strictness of the new rules.
2191
8ab31c0c 2192 if Is_Predefined_Unit (Get_Source_Unit (Subp))
da9683f4
AC
2193 and then not In_Extended_Main_Source_Unit (Subp)
2194 then
2195 null;
2196
2197 elsif Has_Pragma_Inline_Always (Subp) then
2198
2199 -- Emit a warning if this is a call to a runtime subprogram
2200 -- which is located inside a generic. Previously this call
2201 -- was silently skipped.
2202
2203 if Is_Generic_Instance (Subp) then
2204 declare
2205 Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
2206 begin
8ab31c0c 2207 if Is_Predefined_Unit (Get_Source_Unit (Gen_P)) then
da9683f4
AC
2208 Set_Is_Inlined (Subp, False);
2209 Error_Msg_NE (Msg & "p?", N, Subp);
2210 return;
2211 end if;
2212 end;
2213 end if;
2214
2215 -- Remove last character (question mark) to make this into an
2216 -- error, because the Inline_Always pragma cannot be obeyed.
2217
2218 Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
2219
2220 else
2221 Set_Is_Inlined (Subp, False);
2222
2223 if Ineffective_Inline_Warnings then
2224 Error_Msg_NE (Msg & "p?", N, Subp);
2225 end if;
2226 end if;
2227 end if;
2228 end Cannot_Inline;
2229
16b10ccc
AC
2230 --------------------------------------------
2231 -- Check_And_Split_Unconstrained_Function --
2232 --------------------------------------------
540d8610 2233
16b10ccc 2234 procedure Check_And_Split_Unconstrained_Function
540d8610
ES
2235 (N : Node_Id;
2236 Spec_Id : Entity_Id;
2237 Body_Id : Entity_Id)
2238 is
2239 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id);
2240 -- Use generic machinery to build an unexpanded body for the subprogram.
2241 -- This body is subsequently used for inline expansions at call sites.
2242
abc856cf
HK
2243 procedure Build_Return_Object_Formal
2244 (Loc : Source_Ptr;
2245 Obj_Decl : Node_Id;
2246 Formals : List_Id);
2247 -- Create a formal parameter for return object declaration Obj_Decl of
2248 -- an extended return statement and add it to list Formals.
2249
540d8610
ES
2250 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean;
2251 -- Return true if we generate code for the function body N, the function
2252 -- body N has no local declarations and its unique statement is a single
2253 -- extended return statement with a handled statements sequence.
2254
abc856cf
HK
2255 procedure Copy_Formals
2256 (Loc : Source_Ptr;
2257 Subp_Id : Entity_Id;
2258 Formals : List_Id);
2259 -- Create new formal parameters from the formal parameters of subprogram
2260 -- Subp_Id and add them to list Formals.
2261
2262 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id;
2263 -- Create a copy of return object declaration Obj_Decl of an extended
2264 -- return statement.
2265
540d8610
ES
2266 procedure Split_Unconstrained_Function
2267 (N : Node_Id;
2268 Spec_Id : Entity_Id);
2269 -- N is an inlined function body that returns an unconstrained type and
2270 -- has a single extended return statement. Split N in two subprograms:
2271 -- a procedure P' and a function F'. The formals of P' duplicate the
7ec25b2b 2272 -- formals of N plus an extra formal which is used to return a value;
540d8610
ES
2273 -- its body is composed by the declarations and list of statements
2274 -- of the extended return statement of N.
2275
2276 --------------------------
2277 -- Build_Body_To_Inline --
2278 --------------------------
2279
2280 procedure Build_Body_To_Inline (N : Node_Id; Spec_Id : Entity_Id) is
66f95f60
AC
2281 procedure Generate_Subprogram_Body
2282 (N : Node_Id;
2283 Body_To_Inline : out Node_Id);
2284 -- Generate a parameterless duplicate of subprogram body N. Note that
2285 -- occurrences of pragmas referencing the formals are removed since
2286 -- they have no meaning when the body is inlined and the formals are
2287 -- rewritten (the analysis of the non-inlined body will handle these
64ac53f4 2288 -- pragmas). A new internal name is associated with Body_To_Inline.
66f95f60 2289
8016e567
PT
2290 ------------------------------
2291 -- Generate_Subprogram_Body --
2292 ------------------------------
66f95f60
AC
2293
2294 procedure Generate_Subprogram_Body
2295 (N : Node_Id;
2296 Body_To_Inline : out Node_Id)
2297 is
2298 begin
2299 -- Within an instance, the body to inline must be treated as a
2300 -- nested generic so that proper global references are preserved.
2301
2302 -- Note that we do not do this at the library level, because it
2303 -- is not needed, and furthermore this causes trouble if front
2304 -- end inlining is activated (-gnatN).
2305
2306 if In_Instance
2307 and then Scope (Current_Scope) /= Standard_Standard
2308 then
5e9cb404
AC
2309 Body_To_Inline :=
2310 Copy_Generic_Node (N, Empty, Instantiating => True);
66f95f60 2311 else
0964be07 2312 Body_To_Inline := New_Copy_Tree (N);
66f95f60
AC
2313 end if;
2314
2315 -- Remove aspects/pragmas that have no meaning in an inlined body
2316
2317 Remove_Aspects_And_Pragmas (Body_To_Inline);
2318
2319 -- We need to capture references to the formals in order
2320 -- to substitute the actuals at the point of inlining, i.e.
2321 -- instantiation. To treat the formals as globals to the body to
2322 -- inline, we nest it within a dummy parameterless subprogram,
2323 -- declared within the real one.
2324
2325 Set_Parameter_Specifications
2326 (Specification (Body_To_Inline), No_List);
2327
2328 -- A new internal name is associated with Body_To_Inline to avoid
2329 -- conflicts when the non-inlined body N is analyzed.
2330
2331 Set_Defining_Unit_Name (Specification (Body_To_Inline),
a8d89c45 2332 Make_Temporary (Sloc (N), 'P'));
66f95f60
AC
2333 Set_Corresponding_Spec (Body_To_Inline, Empty);
2334 end Generate_Subprogram_Body;
2335
2336 -- Local variables
2337
540d8610
ES
2338 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2339 Original_Body : Node_Id;
2340 Body_To_Analyze : Node_Id;
2341
dba246bf
BD
2342 -- Start of processing for Build_Body_To_Inline
2343
540d8610
ES
2344 begin
2345 pragma Assert (Current_Scope = Spec_Id);
2346
2347 -- Within an instance, the body to inline must be treated as a nested
2348 -- generic, so that the proper global references are preserved. We
2349 -- do not do this at the library level, because it is not needed, and
66f95f60 2350 -- furthermore this causes trouble if front-end inlining is activated
540d8610
ES
2351 -- (-gnatN).
2352
2353 if In_Instance
2354 and then Scope (Current_Scope) /= Standard_Standard
2355 then
2356 Save_Env (Scope (Current_Scope), Scope (Current_Scope));
2357 end if;
2358
643827e9
SB
2359 -- Capture references to formals in order to substitute the actuals
2360 -- at the point of inlining or instantiation. To treat the formals
2361 -- as globals to the body to inline, nest the body within a dummy
2362 -- parameterless subprogram, declared within the real one.
540d8610 2363
16b10ccc 2364 Generate_Subprogram_Body (N, Original_Body);
5e9cb404
AC
2365 Body_To_Analyze :=
2366 Copy_Generic_Node (Original_Body, Empty, Instantiating => False);
540d8610
ES
2367
2368 -- Set return type of function, which is also global and does not
2369 -- need to be resolved.
2370
2371 if Ekind (Spec_Id) = E_Function then
2372 Set_Result_Definition (Specification (Body_To_Analyze),
2373 New_Occurrence_Of (Etype (Spec_Id), Sloc (N)));
2374 end if;
2375
2376 if No (Declarations (N)) then
2377 Set_Declarations (N, New_List (Body_To_Analyze));
2378 else
2379 Append_To (Declarations (N), Body_To_Analyze);
2380 end if;
2381
2382 Preanalyze (Body_To_Analyze);
2383
2384 Push_Scope (Defining_Entity (Body_To_Analyze));
2385 Save_Global_References (Original_Body);
2386 End_Scope;
2387 Remove (Body_To_Analyze);
2388
2389 -- Restore environment if previously saved
2390
2391 if In_Instance
2392 and then Scope (Current_Scope) /= Standard_Standard
2393 then
2394 Restore_Env;
2395 end if;
2396
2397 pragma Assert (No (Body_To_Inline (Decl)));
2398 Set_Body_To_Inline (Decl, Original_Body);
2e02ab86 2399 Mutate_Ekind (Defining_Entity (Original_Body), Ekind (Spec_Id));
540d8610
ES
2400 end Build_Body_To_Inline;
2401
abc856cf
HK
2402 --------------------------------
2403 -- Build_Return_Object_Formal --
2404 --------------------------------
2405
2406 procedure Build_Return_Object_Formal
2407 (Loc : Source_Ptr;
2408 Obj_Decl : Node_Id;
2409 Formals : List_Id)
2410 is
2411 Obj_Def : constant Node_Id := Object_Definition (Obj_Decl);
2412 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
2413 Typ_Def : Node_Id;
2414
2415 begin
2416 -- Build the type definition of the formal parameter. The use of
2417 -- New_Copy_Tree ensures that global references preserved in the
2418 -- case of generics.
2419
2420 if Is_Entity_Name (Obj_Def) then
2421 Typ_Def := New_Copy_Tree (Obj_Def);
2422 else
2423 Typ_Def := New_Copy_Tree (Subtype_Mark (Obj_Def));
2424 end if;
2425
2426 -- Generate:
2427 --
2428 -- Obj_Id : [out] Typ_Def
2429
2430 -- Mode OUT should not be used when the return object is declared as
2431 -- a constant. Check the definition of the object declaration because
2432 -- the object has not been analyzed yet.
2433
2434 Append_To (Formals,
2435 Make_Parameter_Specification (Loc,
75da7a6b 2436 Defining_Identifier =>
abc856cf 2437 Make_Defining_Identifier (Loc, Chars (Obj_Id)),
75da7a6b
PT
2438 In_Present => False,
2439 Out_Present => not Constant_Present (Obj_Decl),
2440 Parameter_Type => Typ_Def));
abc856cf
HK
2441 end Build_Return_Object_Formal;
2442
540d8610
ES
2443 --------------------------------------
2444 -- Can_Split_Unconstrained_Function --
2445 --------------------------------------
2446
643827e9 2447 function Can_Split_Unconstrained_Function (N : Node_Id) return Boolean is
abc856cf
HK
2448 Stmt : constant Node_Id :=
2449 First (Statements (Handled_Statement_Sequence (N)));
2450 Decl : Node_Id;
540d8610
ES
2451
2452 begin
2453 -- No user defined declarations allowed in the function except inside
2454 -- the unique return statement; implicit labels are the only allowed
2455 -- declarations.
2456
abc856cf
HK
2457 Decl := First (Declarations (N));
2458 while Present (Decl) loop
2459 if Nkind (Decl) /= N_Implicit_Label_Declaration then
2460 return False;
2461 end if;
540d8610 2462
abc856cf
HK
2463 Next (Decl);
2464 end loop;
540d8610
ES
2465
2466 -- We only split the inlined function when we are generating the code
2467 -- of its body; otherwise we leave duplicated split subprograms in
2468 -- the tree which (if referenced) generate wrong references at link
2469 -- time.
2470
2471 return In_Extended_Main_Code_Unit (N)
abc856cf
HK
2472 and then Present (Stmt)
2473 and then Nkind (Stmt) = N_Extended_Return_Statement
2474 and then No (Next (Stmt))
2475 and then Present (Handled_Statement_Sequence (Stmt));
540d8610
ES
2476 end Can_Split_Unconstrained_Function;
2477
abc856cf
HK
2478 ------------------
2479 -- Copy_Formals --
2480 ------------------
2481
2482 procedure Copy_Formals
2483 (Loc : Source_Ptr;
2484 Subp_Id : Entity_Id;
2485 Formals : List_Id)
2486 is
2487 Formal : Entity_Id;
2488 Spec : Node_Id;
2489
2490 begin
2491 Formal := First_Formal (Subp_Id);
2492 while Present (Formal) loop
2493 Spec := Parent (Formal);
2494
2495 -- Create an exact copy of the formal parameter. The use of
2496 -- New_Copy_Tree ensures that global references are preserved
2497 -- in case of generics.
2498
2499 Append_To (Formals,
2500 Make_Parameter_Specification (Loc,
2501 Defining_Identifier =>
2502 Make_Defining_Identifier (Sloc (Formal), Chars (Formal)),
2503 In_Present => In_Present (Spec),
2504 Out_Present => Out_Present (Spec),
2505 Null_Exclusion_Present => Null_Exclusion_Present (Spec),
2506 Parameter_Type =>
2507 New_Copy_Tree (Parameter_Type (Spec)),
2508 Expression => New_Copy_Tree (Expression (Spec))));
2509
2510 Next_Formal (Formal);
2511 end loop;
2512 end Copy_Formals;
2513
2514 ------------------------
2515 -- Copy_Return_Object --
2516 ------------------------
2517
2518 function Copy_Return_Object (Obj_Decl : Node_Id) return Node_Id is
fb8e3581 2519 Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
abc856cf
HK
2520
2521 begin
2522 -- The use of New_Copy_Tree ensures that global references are
2523 -- preserved in case of generics.
2524
2525 return
2526 Make_Object_Declaration (Sloc (Obj_Decl),
2527 Defining_Identifier =>
2528 Make_Defining_Identifier (Sloc (Obj_Id), Chars (Obj_Id)),
2529 Aliased_Present => Aliased_Present (Obj_Decl),
2530 Constant_Present => Constant_Present (Obj_Decl),
2531 Null_Exclusion_Present => Null_Exclusion_Present (Obj_Decl),
2532 Object_Definition =>
2533 New_Copy_Tree (Object_Definition (Obj_Decl)),
2534 Expression => New_Copy_Tree (Expression (Obj_Decl)));
2535 end Copy_Return_Object;
2536
540d8610
ES
2537 ----------------------------------
2538 -- Split_Unconstrained_Function --
2539 ----------------------------------
2540
2541 procedure Split_Unconstrained_Function
2542 (N : Node_Id;
2543 Spec_Id : Entity_Id)
2544 is
2545 Loc : constant Source_Ptr := Sloc (N);
abc856cf 2546 Ret_Stmt : constant Node_Id :=
540d8610
ES
2547 First (Statements (Handled_Statement_Sequence (N)));
2548 Ret_Obj : constant Node_Id :=
abc856cf 2549 First (Return_Object_Declarations (Ret_Stmt));
540d8610
ES
2550
2551 procedure Build_Procedure
2552 (Proc_Id : out Entity_Id;
2553 Decl_List : out List_Id);
2554 -- Build a procedure containing the statements found in the extended
2555 -- return statement of the unconstrained function body N.
2556
3f80a182
AC
2557 ---------------------
2558 -- Build_Procedure --
2559 ---------------------
2560
540d8610
ES
2561 procedure Build_Procedure
2562 (Proc_Id : out Entity_Id;
2563 Decl_List : out List_Id)
2564 is
8af95ac6
PT
2565 Formals : constant List_Id := New_List;
2566 Subp_Name : constant Name_Id := New_Internal_Name ('F');
540d8610 2567
abc856cf
HK
2568 Body_Decls : List_Id := No_List;
2569 Decl : Node_Id;
2570 Proc_Body : Node_Id;
2571 Proc_Spec : Node_Id;
540d8610 2572
abc856cf
HK
2573 begin
2574 -- Create formal parameters for the return object and all formals
2575 -- of the unconstrained function in order to pass their values to
2576 -- the procedure.
596f7139 2577
abc856cf
HK
2578 Build_Return_Object_Formal
2579 (Loc => Loc,
2580 Obj_Decl => Ret_Obj,
2581 Formals => Formals);
540d8610 2582
abc856cf
HK
2583 Copy_Formals
2584 (Loc => Loc,
2585 Subp_Id => Spec_Id,
2586 Formals => Formals);
540d8610 2587
3f80a182 2588 Proc_Id := Make_Defining_Identifier (Loc, Chars => Subp_Name);
540d8610
ES
2589
2590 Proc_Spec :=
2591 Make_Procedure_Specification (Loc,
3f80a182 2592 Defining_Unit_Name => Proc_Id,
abc856cf 2593 Parameter_Specifications => Formals);
540d8610
ES
2594
2595 Decl_List := New_List;
2596
2597 Append_To (Decl_List,
2598 Make_Subprogram_Declaration (Loc, Proc_Spec));
2599
2600 -- Can_Convert_Unconstrained_Function checked that the function
2601 -- has no local declarations except implicit label declarations.
2602 -- Copy these declarations to the built procedure.
2603
2604 if Present (Declarations (N)) then
abc856cf 2605 Body_Decls := New_List;
540d8610 2606
abc856cf
HK
2607 Decl := First (Declarations (N));
2608 while Present (Decl) loop
2609 pragma Assert (Nkind (Decl) = N_Implicit_Label_Declaration);
540d8610 2610
abc856cf
HK
2611 Append_To (Body_Decls,
2612 Make_Implicit_Label_Declaration (Loc,
2613 Make_Defining_Identifier (Loc,
2614 Chars => Chars (Defining_Identifier (Decl))),
2615 Label_Construct => Empty));
2616
2617 Next (Decl);
2618 end loop;
540d8610
ES
2619 end if;
2620
abc856cf 2621 pragma Assert (Present (Handled_Statement_Sequence (Ret_Stmt)));
540d8610
ES
2622
2623 Proc_Body :=
2624 Make_Subprogram_Body (Loc,
abc856cf
HK
2625 Specification => Copy_Subprogram_Spec (Proc_Spec),
2626 Declarations => Body_Decls,
540d8610 2627 Handled_Statement_Sequence =>
abc856cf 2628 New_Copy_Tree (Handled_Statement_Sequence (Ret_Stmt)));
540d8610
ES
2629
2630 Set_Defining_Unit_Name (Specification (Proc_Body),
2631 Make_Defining_Identifier (Loc, Subp_Name));
2632
2633 Append_To (Decl_List, Proc_Body);
2634 end Build_Procedure;
2635
2636 -- Local variables
2637
abc856cf 2638 New_Obj : constant Node_Id := Copy_Return_Object (Ret_Obj);
540d8610 2639 Blk_Stmt : Node_Id;
540d8610 2640 Proc_Call : Node_Id;
abc856cf 2641 Proc_Id : Entity_Id;
540d8610
ES
2642
2643 -- Start of processing for Split_Unconstrained_Function
2644
2645 begin
2646 -- Build the associated procedure, analyze it and insert it before
3f80a182 2647 -- the function body N.
540d8610
ES
2648
2649 declare
2650 Scope : constant Entity_Id := Current_Scope;
2651 Decl_List : List_Id;
2652 begin
2653 Pop_Scope;
2654 Build_Procedure (Proc_Id, Decl_List);
2655 Insert_Actions (N, Decl_List);
7ec25b2b 2656 Set_Is_Inlined (Proc_Id);
540d8610
ES
2657 Push_Scope (Scope);
2658 end;
2659
2660 -- Build the call to the generated procedure
2661
2662 declare
2663 Actual_List : constant List_Id := New_List;
2664 Formal : Entity_Id;
2665
2666 begin
2667 Append_To (Actual_List,
2668 New_Occurrence_Of (Defining_Identifier (New_Obj), Loc));
2669
2670 Formal := First_Formal (Spec_Id);
2671 while Present (Formal) loop
2672 Append_To (Actual_List, New_Occurrence_Of (Formal, Loc));
2673
2674 -- Avoid spurious warning on unreferenced formals
2675
2676 Set_Referenced (Formal);
2677 Next_Formal (Formal);
2678 end loop;
2679
2680 Proc_Call :=
2681 Make_Procedure_Call_Statement (Loc,
3f80a182 2682 Name => New_Occurrence_Of (Proc_Id, Loc),
540d8610
ES
2683 Parameter_Associations => Actual_List);
2684 end;
2685
66f95f60 2686 -- Generate:
540d8610
ES
2687
2688 -- declare
2689 -- New_Obj : ...
2690 -- begin
66f95f60
AC
2691 -- Proc (New_Obj, ...);
2692 -- return New_Obj;
2693 -- end;
540d8610
ES
2694
2695 Blk_Stmt :=
2696 Make_Block_Statement (Loc,
3f80a182 2697 Declarations => New_List (New_Obj),
540d8610
ES
2698 Handled_Statement_Sequence =>
2699 Make_Handled_Sequence_Of_Statements (Loc,
2700 Statements => New_List (
2701
2702 Proc_Call,
2703
2704 Make_Simple_Return_Statement (Loc,
2705 Expression =>
2706 New_Occurrence_Of
2707 (Defining_Identifier (New_Obj), Loc)))));
2708
abc856cf 2709 Rewrite (Ret_Stmt, Blk_Stmt);
540d8610
ES
2710 end Split_Unconstrained_Function;
2711
16b10ccc
AC
2712 -- Local variables
2713
2714 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2715
2716 -- Start of processing for Check_And_Split_Unconstrained_Function
540d8610
ES
2717
2718 begin
16b10ccc
AC
2719 pragma Assert (Back_End_Inlining
2720 and then Ekind (Spec_Id) = E_Function
2721 and then Returns_Unconstrained_Type (Spec_Id)
2722 and then Comes_From_Source (Body_Id)
2723 and then (Has_Pragma_Inline_Always (Spec_Id)
2724 or else Optimization_Level > 0));
2725
2726 -- This routine must not be used in GNATprove mode since GNATprove
2727 -- relies on frontend inlining
2728
2729 pragma Assert (not GNATprove_Mode);
2730
2731 -- No need to split the function if we cannot generate the code
2732
2733 if Serious_Errors_Detected /= 0 then
2734 return;
2735 end if;
2736
16b10ccc
AC
2737 -- No action needed in stubs since the attribute Body_To_Inline
2738 -- is not available
4bd4bb7f 2739
16b10ccc
AC
2740 if Nkind (Decl) = N_Subprogram_Body_Stub then
2741 return;
2742
2743 -- Cannot build the body to inline if the attribute is already set.
2744 -- This attribute may have been set if this is a subprogram renaming
2745 -- declarations (see Freeze.Build_Renamed_Body).
2746
2747 elsif Present (Body_To_Inline (Decl)) then
2748 return;
2749
dba246bf
BD
2750 -- Do not generate a body to inline for protected functions, because the
2751 -- transformation generates a call to a protected procedure, causing
2752 -- spurious errors. We don't inline protected operations anyway, so
2753 -- this is no loss. We might as well ignore intrinsics and foreign
2754 -- conventions as well -- just allow Ada conventions.
2755
2756 elsif not (Convention (Spec_Id) = Convention_Ada
2757 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Copy
2758 or else Convention (Spec_Id) = Convention_Ada_Pass_By_Reference)
2759 then
2760 return;
2761
16b10ccc
AC
2762 -- Check excluded declarations
2763
d7f5bfe4 2764 elsif Has_Excluded_Declaration (Spec_Id, Declarations (N)) then
16b10ccc
AC
2765 return;
2766
2767 -- Check excluded statements. There is no need to protect us against
2768 -- exception handlers since they are supported by the GCC backend.
2769
2770 elsif Present (Handled_Statement_Sequence (N))
2771 and then Has_Excluded_Statement
2772 (Spec_Id, Statements (Handled_Statement_Sequence (N)))
2773 then
2774 return;
540d8610
ES
2775 end if;
2776
2777 -- Build the body to inline only if really needed
2778
16b10ccc
AC
2779 if Can_Split_Unconstrained_Function (N) then
2780 Split_Unconstrained_Function (N, Spec_Id);
2781 Build_Body_To_Inline (N, Spec_Id);
2782 Set_Is_Inlined (Spec_Id);
540d8610 2783 end if;
16b10ccc 2784 end Check_And_Split_Unconstrained_Function;
3f80a182 2785
3c802e97
YM
2786 ---------------------------------------------
2787 -- Check_Object_Renaming_In_GNATprove_Mode --
2788 ---------------------------------------------
2789
2790 procedure Check_Object_Renaming_In_GNATprove_Mode (Spec_Id : Entity_Id) is
2791 Decl : constant Node_Id := Unit_Declaration_Node (Spec_Id);
2792 Body_Decl : constant Node_Id :=
2793 Unit_Declaration_Node (Corresponding_Body (Decl));
2794
2795 function Check_Object_Renaming (N : Node_Id) return Traverse_Result;
2796 -- Returns Abandon on node N if this is a reference to an object
2797 -- renaming, which will be expanded into the renamed object in
2798 -- GNATprove mode.
2799
2800 ---------------------------
2801 -- Check_Object_Renaming --
2802 ---------------------------
2803
2804 function Check_Object_Renaming (N : Node_Id) return Traverse_Result is
2805 begin
2806 case Nkind (Original_Node (N)) is
2807 when N_Expanded_Name
2808 | N_Identifier
2809 =>
2810 declare
2811 Obj_Id : constant Entity_Id := Entity (Original_Node (N));
2812 begin
2813 -- Recognize the case when SPARK expansion rewrites a
2814 -- reference to an object renaming.
2815
2816 if Present (Obj_Id)
2817 and then Is_Object (Obj_Id)
2818 and then Present (Renamed_Object (Obj_Id))
2819 and then Nkind (Renamed_Object (Obj_Id)) not in N_Entity
2820
2821 -- Copy_Generic_Node called for inlining expects the
2822 -- references to global entities to have the same kind
2823 -- in the "generic" code and its "instantiation".
2824
2825 and then Nkind (Original_Node (N)) /=
2826 Nkind (Renamed_Object (Obj_Id))
2827 then
2828 return Abandon;
2829 else
2830 return OK;
2831 end if;
2832 end;
2833
2834 when others =>
2835 return OK;
2836 end case;
2837 end Check_Object_Renaming;
2838
2839 function Check_All_Object_Renamings is new
2840 Traverse_Func (Check_Object_Renaming);
2841
2842 -- Start of processing for Check_Object_Renaming_In_GNATprove_Mode
2843
2844 begin
2845 -- Subprograms with object renamings replaced by the special SPARK
2846 -- expansion cannot be inlined.
2847
2848 if Check_All_Object_Renamings (Body_Decl) /= OK then
2849 Cannot_Inline ("cannot inline & (object renaming)?",
2850 Body_Decl, Spec_Id);
2851 Set_Body_To_Inline (Decl, Empty);
2852 end if;
2853 end Check_Object_Renaming_In_GNATprove_Mode;
2854
1773d80b
AC
2855 -------------------------------------
2856 -- Check_Package_Body_For_Inlining --
2857 -------------------------------------
540d8610 2858
1773d80b 2859 procedure Check_Package_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
540d8610
ES
2860 Bname : Unit_Name_Type;
2861 E : Entity_Id;
2862 OK : Boolean;
2863
2864 begin
88f7d2d1
AC
2865 -- Legacy implementation (relying on frontend inlining)
2866
2867 if not Back_End_Inlining
039538bc 2868 and then Is_Compilation_Unit (P)
540d8610
ES
2869 and then not Is_Generic_Instance (P)
2870 then
2871 Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
2872
2873 E := First_Entity (P);
2874 while Present (E) loop
88f7d2d1
AC
2875 if Has_Pragma_Inline_Always (E)
2876 or else (Has_Pragma_Inline (E) and Front_End_Inlining)
2877 then
540d8610
ES
2878 if not Is_Loaded (Bname) then
2879 Load_Needed_Body (N, OK);
2880
2881 if OK then
2882
2883 -- Check we are not trying to inline a parent whose body
2884 -- depends on a child, when we are compiling the body of
2885 -- the child. Otherwise we have a potential elaboration
2886 -- circularity with inlined subprograms and with
2887 -- Taft-Amendment types.
2888
2889 declare
2890 Comp : Node_Id; -- Body just compiled
2891 Child_Spec : Entity_Id; -- Spec of main unit
2892 Ent : Entity_Id; -- For iteration
2893 With_Clause : Node_Id; -- Context of body.
2894
2895 begin
2896 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
2897 and then Present (Body_Entity (P))
2898 then
2899 Child_Spec :=
2900 Defining_Entity
16007e34 2901 ((Unit (Spec_Lib_Unit (Cunit (Main_Unit)))));
540d8610
ES
2902
2903 Comp :=
2904 Parent (Unit_Declaration_Node (Body_Entity (P)));
2905
2906 -- Check whether the context of the body just
2907 -- compiled includes a child of itself, and that
2908 -- child is the spec of the main compilation.
2909
2910 With_Clause := First (Context_Items (Comp));
2911 while Present (With_Clause) loop
2912 if Nkind (With_Clause) = N_With_Clause
2913 and then
2914 Scope (Entity (Name (With_Clause))) = P
2915 and then
2916 Entity (Name (With_Clause)) = Child_Spec
2917 then
2918 Error_Msg_Node_2 := Child_Spec;
2919 Error_Msg_NE
2920 ("body of & depends on child unit&??",
2921 With_Clause, P);
2922 Error_Msg_N
2923 ("\subprograms in body cannot be inlined??",
2924 With_Clause);
2925
2926 -- Disable further inlining from this unit,
2927 -- and keep Taft-amendment types incomplete.
2928
2929 Ent := First_Entity (P);
2930 while Present (Ent) loop
2931 if Is_Type (Ent)
3f80a182 2932 and then Has_Completion_In_Body (Ent)
540d8610
ES
2933 then
2934 Set_Full_View (Ent, Empty);
2935
2936 elsif Is_Subprogram (Ent) then
2937 Set_Is_Inlined (Ent, False);
2938 end if;
2939
2940 Next_Entity (Ent);
2941 end loop;
2942
2943 return;
2944 end if;
2945
2946 Next (With_Clause);
2947 end loop;
2948 end if;
2949 end;
2950
2951 elsif Ineffective_Inline_Warnings then
2952 Error_Msg_Unit_1 := Bname;
2953 Error_Msg_N
9baae569
GL
2954 ("unable to inline subprograms defined in $?p?", P);
2955 Error_Msg_N ("\body not found?p?", P);
540d8610
ES
2956 return;
2957 end if;
2958 end if;
2959
2960 return;
2961 end if;
2962
2963 Next_Entity (E);
2964 end loop;
2965 end if;
1773d80b 2966 end Check_Package_Body_For_Inlining;
540d8610
ES
2967
2968 --------------------
2969 -- Cleanup_Scopes --
2970 --------------------
2971
2972 procedure Cleanup_Scopes is
540d8610 2973 Decl : Node_Id;
0c1d2675
EB
2974 Elmt : Elmt_Id;
2975 Fin : Entity_Id;
2976 Kind : Entity_Kind;
540d8610
ES
2977 Scop : Entity_Id;
2978
2979 begin
2980 Elmt := First_Elmt (To_Clean);
2981 while Present (Elmt) loop
2982 Scop := Node (Elmt);
0c1d2675 2983 Kind := Ekind (Scop);
540d8610 2984
0c1d2675 2985 if Kind = E_Block then
540d8610
ES
2986 Decl := Parent (Block_Node (Scop));
2987
2988 else
2989 Decl := Unit_Declaration_Node (Scop);
2990
4a08c95c
AC
2991 if Nkind (Decl) in N_Subprogram_Declaration
2992 | N_Task_Type_Declaration
2993 | N_Subprogram_Body_Stub
540d8610
ES
2994 then
2995 Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
2996 end if;
2997 end if;
2998
0c1d2675
EB
2999 -- Finalizers are built only for package specs and bodies that are
3000 -- compilation units, so check that we do not have anything else.
3001 -- Moreover, they must be built at most once for each entity during
3002 -- the compilation of the main unit. However, if other units are
3003 -- later compiled for inlining purposes, they may also contain body
3004 -- instances and, therefore, appear again here, so we need to make
3005 -- sure that we do not build two finalizers for them (note that the
3006 -- contents of the finalizer for these units is irrelevant since it
3007 -- is not output in the generated code).
3008
3009 if Kind in E_Package | E_Package_Body then
3010 declare
3011 Unit_Entity : constant Entity_Id :=
3012 (if Kind = E_Package then Scop else Spec_Entity (Scop));
3013
3014 begin
3015 pragma Assert (Is_Compilation_Unit (Unit_Entity)
3016 and then (No (Finalizer (Scop))
3017 or else Unit_Entity /= Main_Unit_Entity));
3018
3019 if No (Finalizer (Scop)) then
3020 Build_Finalizer
3021 (N => Decl,
3022 Clean_Stmts => No_List,
3023 Mark_Id => Empty,
0c1d2675
EB
3024 Defer_Abort => False,
3025 Fin_Id => Fin);
3026
3027 if Present (Fin) then
3028 Set_Finalizer (Scop, Fin);
3029 end if;
3030 end if;
3031 end;
3032
3033 else
3034 Push_Scope (Scop);
3035 Expand_Cleanup_Actions (Decl);
5a6dbb34 3036 Pop_Scope;
0c1d2675 3037 end if;
540d8610 3038
99859ea7 3039 Next_Elmt (Elmt);
540d8610
ES
3040 end loop;
3041 end Cleanup_Scopes;
3042
0c1d2675
EB
3043 -----------------------------------------------
3044 -- Establish_Actual_Mapping_For_Inlined_Call --
3045 -----------------------------------------------
3046
bbab2db3
GD
3047 procedure Establish_Actual_Mapping_For_Inlined_Call
3048 (N : Node_Id;
3049 Subp : Entity_Id;
3050 Decls : List_Id;
3051 Body_Or_Expr_To_Check : Node_Id)
540d8610 3052 is
6778c2ca 3053
bbab2db3
GD
3054 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
3055 -- Determine whether a formal parameter is used only once in
3056 -- Body_Or_Expr_To_Check.
540d8610 3057
bbab2db3
GD
3058 -------------------------
3059 -- Formal_Is_Used_Once --
3060 -------------------------
6778c2ca 3061
bbab2db3 3062 function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean is
33d1be87 3063 Use_Counter : Nat := 0;
6778c2ca 3064
bbab2db3
GD
3065 function Count_Uses (N : Node_Id) return Traverse_Result;
3066 -- Traverse the tree and count the uses of the formal parameter.
3067 -- In this case, for optimization purposes, we do not need to
3068 -- continue the traversal once more than one use is encountered.
540d8610 3069
bbab2db3
GD
3070 ----------------
3071 -- Count_Uses --
3072 ----------------
540d8610 3073
bbab2db3
GD
3074 function Count_Uses (N : Node_Id) return Traverse_Result is
3075 begin
3076 -- The original node is an identifier
540d8610 3077
bbab2db3
GD
3078 if Nkind (N) = N_Identifier
3079 and then Present (Entity (N))
64f5d139 3080
bbab2db3 3081 -- Original node's entity points to the one in the copied body
540d8610 3082
bbab2db3
GD
3083 and then Nkind (Entity (N)) = N_Identifier
3084 and then Present (Entity (Entity (N)))
b5c8da6b 3085
bbab2db3 3086 -- The entity of the copied node is the formal parameter
540d8610 3087
bbab2db3
GD
3088 and then Entity (Entity (N)) = Formal
3089 then
3090 Use_Counter := Use_Counter + 1;
5460389b 3091
33d1be87 3092 -- If this is a second use then abandon the traversal
540d8610 3093
33d1be87 3094 if Use_Counter > 1 then
bbab2db3 3095 return Abandon;
bbab2db3
GD
3096 end if;
3097 end if;
540d8610 3098
bbab2db3
GD
3099 return OK;
3100 end Count_Uses;
540d8610 3101
bbab2db3 3102 procedure Count_Formal_Uses is new Traverse_Proc (Count_Uses);
64f5d139 3103
bbab2db3 3104 -- Start of processing for Formal_Is_Used_Once
64f5d139
JM
3105
3106 begin
bbab2db3
GD
3107 Count_Formal_Uses (Body_Or_Expr_To_Check);
3108 return Use_Counter = 1;
3109 end Formal_Is_Used_Once;
64f5d139 3110
bbab2db3 3111 -- Local Data --
64f5d139 3112
bbab2db3
GD
3113 F : Entity_Id;
3114 A : Node_Id;
3115 Decl : Node_Id;
3116 Loc : constant Source_Ptr := Sloc (N);
3117 New_A : Node_Id;
3118 Temp : Entity_Id;
3119 Temp_Typ : Entity_Id;
540d8610 3120
bbab2db3 3121 -- Start of processing for Establish_Actual_Mapping_For_Inlined_Call
540d8610 3122
bbab2db3
GD
3123 begin
3124 F := First_Formal (Subp);
3125 A := First_Actual (N);
3126 while Present (F) loop
bbab2db3
GD
3127 -- Reset Last_Assignment for any parameters of mode out or in out, to
3128 -- prevent spurious warnings about overwriting for assignments to the
3129 -- formal in the inlined code.
6cbd53c2 3130
bbab2db3 3131 if Is_Entity_Name (A) and then Ekind (F) /= E_In_Parameter then
acd4ef9d
PT
3132
3133 -- In GNATprove mode a protected component acting as an actual
3134 -- subprogram parameter will appear as inlined-for-proof. However,
3135 -- its E_Component entity is not an assignable object, so the
3136 -- assertion in Set_Last_Assignment will fail. We just omit the
3137 -- call to Set_Last_Assignment, because GNATprove flags useless
3138 -- assignments with its own flow analysis.
3139 --
3140 -- In GNAT mode such a problem does not occur, because protected
3141 -- components are inlined via object renamings whose entity kind
3142 -- E_Variable is assignable.
3143
3144 if Is_Assignable (Entity (A)) then
3145 Set_Last_Assignment (Entity (A), Empty);
3146 else
3147 pragma Assert
3148 (GNATprove_Mode and then Is_Protected_Component (Entity (A)));
3149 end if;
bbab2db3 3150 end if;
6cbd53c2 3151
bbab2db3
GD
3152 -- If the argument may be a controlling argument in a call within
3153 -- the inlined body, we must preserve its class-wide nature to ensure
3154 -- that dynamic dispatching will take place subsequently. If the
3155 -- formal has a constraint, then it must be preserved to retain the
3156 -- semantics of the body.
6cbd53c2 3157
bbab2db3
GD
3158 if Is_Class_Wide_Type (Etype (F))
3159 or else (Is_Access_Type (Etype (F))
3160 and then Is_Class_Wide_Type (Designated_Type (Etype (F))))
3161 then
3162 Temp_Typ := Etype (F);
6cbd53c2 3163
bbab2db3
GD
3164 elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
3165 and then Etype (F) /= Base_Type (Etype (F))
3c6dcd1d
YM
3166 and then (Is_Constrained (Etype (F))
3167 or else
3168 Is_Fixed_Lower_Bound_Array_Subtype (Etype (F)))
bbab2db3
GD
3169 then
3170 Temp_Typ := Etype (F);
6cbd53c2 3171
bbab2db3
GD
3172 else
3173 Temp_Typ := Etype (A);
3174 end if;
6cbd53c2 3175
76b35e72
PT
3176 -- If the actual is a simple name or a literal, no need to create a
3177 -- temporary, object can be used directly. Skip this optimization in
3178 -- GNATprove mode, to make sure any check on a type conversion will
3179 -- be issued.
b5c8da6b 3180
bbab2db3
GD
3181 if (Is_Entity_Name (A)
3182 and then
3183 (not Is_Scalar_Type (Etype (A))
3184 or else Ekind (Entity (A)) = E_Enumeration_Literal)
3185 and then not GNATprove_Mode)
3186
3187 -- When the actual is an identifier and the corresponding formal is
3188 -- used only once in the original body, the formal can be substituted
3189 -- directly with the actual parameter. Skip this optimization in
3190 -- GNATprove mode, to make sure any check on a type conversion
3191 -- will be issued.
3192
3193 or else
3194 (Nkind (A) = N_Identifier
3195 and then Formal_Is_Used_Once (F)
3196 and then not GNATprove_Mode)
3197
76b35e72
PT
3198 -- If the actual is a literal and the formal has its address taken,
3199 -- we cannot pass the literal itself as an argument, so its value
3200 -- must be captured in a temporary.
3201
bbab2db3 3202 or else
4a08c95c
AC
3203 (Nkind (A) in
3204 N_Real_Literal | N_Integer_Literal | N_Character_Literal
bbab2db3
GD
3205 and then not Address_Taken (F))
3206 then
3207 if Etype (F) /= Etype (A) then
3208 Set_Renamed_Object
3209 (F, Unchecked_Convert_To (Etype (F), Relocate_Node (A)));
3210 else
3211 Set_Renamed_Object (F, A);
3212 end if;
3213
3214 else
3215 Temp := Make_Temporary (Loc, 'C');
3216
3217 -- If the actual for an in/in-out parameter is a view conversion,
3218 -- make it into an unchecked conversion, given that an untagged
3219 -- type conversion is not a proper object for a renaming.
3220
3221 -- In-out conversions that involve real conversions have already
3222 -- been transformed in Expand_Actuals.
3223
3224 if Nkind (A) = N_Type_Conversion
3225 and then Ekind (F) /= E_In_Parameter
3226 then
738a0e8d 3227 New_A := Unchecked_Convert_To (Etype (F), Expression (A));
bbab2db3
GD
3228
3229 -- In GNATprove mode, keep the most precise type of the actual for
3230 -- the temporary variable, when the formal type is unconstrained.
3231 -- Otherwise, the AST may contain unexpected assignment statements
3232 -- to a temporary variable of unconstrained type renaming a local
3233 -- variable of constrained type, which is not expected by
3234 -- GNATprove.
3235
3236 elsif Etype (F) /= Etype (A)
3c6dcd1d
YM
3237 and then
3238 (not GNATprove_Mode
3239 or else (Is_Constrained (Etype (F))
3240 or else
3241 Is_Fixed_Lower_Bound_Array_Subtype (Etype (F))))
bbab2db3
GD
3242 then
3243 New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
3244 Temp_Typ := Etype (F);
3245
3246 else
3247 New_A := Relocate_Node (A);
3248 end if;
3249
3250 Set_Sloc (New_A, Sloc (N));
3251
3252 -- If the actual has a by-reference type, it cannot be copied,
3253 -- so its value is captured in a renaming declaration. Otherwise
3254 -- declare a local constant initialized with the actual.
3255
3256 -- We also use a renaming declaration for expressions of an array
3257 -- type that is not bit-packed, both for efficiency reasons and to
3258 -- respect the semantics of the call: in most cases the original
3259 -- call will pass the parameter by reference, and thus the inlined
3260 -- code will have the same semantics.
3261
3262 -- Finally, we need a renaming declaration in the case of limited
3263 -- types for which initialization cannot be by copy either.
3264
3265 if Ekind (F) = E_In_Parameter
3266 and then not Is_By_Reference_Type (Etype (A))
3267 and then not Is_Limited_Type (Etype (A))
3268 and then
3269 (not Is_Array_Type (Etype (A))
3270 or else not Is_Object_Reference (A)
3271 or else Is_Bit_Packed_Array (Etype (A)))
3272 then
3273 Decl :=
3274 Make_Object_Declaration (Loc,
3275 Defining_Identifier => Temp,
3276 Constant_Present => True,
3277 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3278 Expression => New_A);
3279
3280 else
3281 -- In GNATprove mode, make an explicit copy of input
3282 -- parameters when formal and actual types differ, to make
3283 -- sure any check on the type conversion will be issued.
3284 -- The legality of the copy is ensured by calling first
3285 -- Call_Can_Be_Inlined_In_GNATprove_Mode.
3286
3287 if GNATprove_Mode
3288 and then Ekind (F) /= E_Out_Parameter
3289 and then not Same_Type (Etype (F), Etype (A))
3290 then
3291 pragma Assert (not Is_By_Reference_Type (Etype (A)));
3292 pragma Assert (not Is_Limited_Type (Etype (A)));
3293
3294 Append_To (Decls,
3295 Make_Object_Declaration (Loc,
3296 Defining_Identifier => Make_Temporary (Loc, 'C'),
3297 Constant_Present => True,
3298 Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
3299 Expression => New_Copy_Tree (New_A)));
3300 end if;
3301
3302 Decl :=
3303 Make_Object_Renaming_Declaration (Loc,
3304 Defining_Identifier => Temp,
3305 Subtype_Mark => New_Occurrence_Of (Temp_Typ, Loc),
3306 Name => New_A);
3307 end if;
3308
3309 Append (Decl, Decls);
3310 Set_Renamed_Object (F, Temp);
3311 end if;
3312
3313 Next_Formal (F);
3314 Next_Actual (A);
3315 end loop;
3316 end Establish_Actual_Mapping_For_Inlined_Call;
3317
3318 -------------------------
3319 -- Expand_Inlined_Call --
3320 -------------------------
3321
3322 procedure Expand_Inlined_Call
42edc837
PT
3323 (N : Node_Id;
3324 Subp : Entity_Id;
3325 Orig_Subp : Entity_Id)
bbab2db3
GD
3326 is
3327 Decls : constant List_Id := New_List;
3328 Is_Predef : constant Boolean :=
3329 Is_Predefined_Unit (Get_Source_Unit (Subp));
3330 Loc : constant Source_Ptr := Sloc (N);
3331 Orig_Bod : constant Node_Id :=
3332 Body_To_Inline (Unit_Declaration_Node (Subp));
3333
3334 Uses_Back_End : constant Boolean :=
3335 Back_End_Inlining and then Optimization_Level > 0;
3336 -- The back-end expansion is used if the target supports back-end
3337 -- inlining and some level of optimixation is required; otherwise
3338 -- the inlining takes place fully as a tree expansion.
3339
3340 Blk : Node_Id;
3341 Decl : Node_Id;
3342 Exit_Lab : Entity_Id := Empty;
3343 Lab_Decl : Node_Id := Empty;
3344 Lab_Id : Node_Id;
3345 Num_Ret : Nat := 0;
3346 Ret_Type : Entity_Id;
3347 Temp : Entity_Id;
3348
3349 Is_Unc : Boolean;
3350 Is_Unc_Decl : Boolean;
3351 -- If the type returned by the function is unconstrained and the call
3352 -- can be inlined, special processing is required.
3353
3354 Return_Object : Entity_Id := Empty;
3355 -- Entity in declaration in an extended_return_statement
3356
3357 Targ : Node_Id := Empty;
3358 -- The target of the call. If context is an assignment statement then
3359 -- this is the left-hand side of the assignment, else it is a temporary
3360 -- to which the return value is assigned prior to rewriting the call.
3361
3362 Targ1 : Node_Id := Empty;
3363 -- A separate target used when the return type is unconstrained
3364
bbab2db3
GD
3365 procedure Make_Exit_Label;
3366 -- Build declaration for exit label to be used in Return statements,
3367 -- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
3368 -- declaration). Does nothing if Exit_Lab already set.
3369
bbab2db3
GD
3370 function Process_Formals (N : Node_Id) return Traverse_Result;
3371 -- Replace occurrence of a formal with the corresponding actual, or the
3372 -- thunk generated for it. Replace a return statement with an assignment
3373 -- to the target of the call, with appropriate conversions if needed.
3374
3375 function Process_Formals_In_Aspects (N : Node_Id) return Traverse_Result;
3376 -- Because aspects are linked indirectly to the rest of the tree,
3377 -- replacement of formals appearing in aspect specifications must
3378 -- be performed in a separate pass, using an instantiation of the
3379 -- previous subprogram over aspect specifications reachable from N.
3380
3381 function Process_Sloc (Nod : Node_Id) return Traverse_Result;
3382 -- If the call being expanded is that of an internal subprogram, set the
3383 -- sloc of the generated block to that of the call itself, so that the
3384 -- expansion is skipped by the "next" command in gdb. Same processing
3385 -- for a subprogram in a predefined file, e.g. Ada.Tags. If
3386 -- Debug_Generated_Code is true, suppress this change to simplify our
3387 -- own development. Same in GNATprove mode, to ensure that warnings and
3388 -- diagnostics point to the proper location.
3389
3390 procedure Reset_Dispatching_Calls (N : Node_Id);
3391 -- In subtree N search for occurrences of dispatching calls that use the
3392 -- Ada 2005 Object.Operation notation and the object is a formal of the
3393 -- inlined subprogram. Reset the entity associated with Operation in all
3394 -- the found occurrences.
3395
3396 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id);
3397 -- If the function body is a single expression, replace call with
3398 -- expression, else insert block appropriately.
3399
bbab2db3
GD
3400 ---------------------
3401 -- Make_Exit_Label --
3402 ---------------------
3403
3404 procedure Make_Exit_Label is
3405 Lab_Ent : Entity_Id;
3406 begin
3407 if No (Exit_Lab) then
3408 Lab_Ent := Make_Temporary (Loc, 'L');
3409 Lab_Id := New_Occurrence_Of (Lab_Ent, Loc);
3410 Exit_Lab := Make_Label (Loc, Lab_Id);
3411 Lab_Decl :=
3412 Make_Implicit_Label_Declaration (Loc,
3413 Defining_Identifier => Lab_Ent,
3414 Label_Construct => Exit_Lab);
3415 end if;
3416 end Make_Exit_Label;
3417
540d8610
ES
3418 ---------------------
3419 -- Process_Formals --
3420 ---------------------
3421
3422 function Process_Formals (N : Node_Id) return Traverse_Result is
b849df9a 3423 Loc : constant Source_Ptr := Sloc (N);
540d8610
ES
3424 A : Entity_Id;
3425 E : Entity_Id;
3426 Ret : Node_Id;
3427
8a99a8e6
PT
3428 Had_Private_View : Boolean;
3429
540d8610
ES
3430 begin
3431 if Is_Entity_Name (N) and then Present (Entity (N)) then
3432 E := Entity (N);
3433
3434 if Is_Formal (E) and then Scope (E) = Subp then
3435 A := Renamed_Object (E);
3436
3437 -- Rewrite the occurrence of the formal into an occurrence of
3438 -- the actual. Also establish visibility on the proper view of
3439 -- the actual's subtype for the body's context (if the actual's
3440 -- subtype is private at the call point but its full view is
3441 -- visible to the body, then the inlined tree here must be
3442 -- analyzed with the full view).
8a99a8e6
PT
3443 --
3444 -- The Has_Private_View flag is cleared by rewriting, so it
3445 -- must be explicitly saved and restored, just like when
3446 -- instantiating the body to inline.
540d8610
ES
3447
3448 if Is_Entity_Name (A) then
8a99a8e6 3449 Had_Private_View := Has_Private_View (N);
b849df9a 3450 Rewrite (N, New_Occurrence_Of (Entity (A), Loc));
8a99a8e6 3451 Set_Has_Private_View (N, Had_Private_View);
540d8610
ES
3452 Check_Private_View (N);
3453
3454 elsif Nkind (A) = N_Defining_Identifier then
8a99a8e6 3455 Had_Private_View := Has_Private_View (N);
b849df9a 3456 Rewrite (N, New_Occurrence_Of (A, Loc));
8a99a8e6 3457 Set_Has_Private_View (N, Had_Private_View);
540d8610
ES
3458 Check_Private_View (N);
3459
3460 -- Numeric literal
3461
3462 else
3463 Rewrite (N, New_Copy (A));
3464 end if;
3465 end if;
3466
3467 return Skip;
3468
3469 elsif Is_Entity_Name (N)
3470 and then Present (Return_Object)
3471 and then Chars (N) = Chars (Return_Object)
3472 then
3473 -- Occurrence within an extended return statement. The return
3474 -- object is local to the body been inlined, and thus the generic
3475 -- copy is not analyzed yet, so we match by name, and replace it
3476 -- with target of call.
3477
3478 if Nkind (Targ) = N_Defining_Identifier then
3479 Rewrite (N, New_Occurrence_Of (Targ, Loc));
3480 else
3481 Rewrite (N, New_Copy_Tree (Targ));
3482 end if;
3483
3484 return Skip;
3485
3486 elsif Nkind (N) = N_Simple_Return_Statement then
3487 if No (Expression (N)) then
00f45f30 3488 Num_Ret := Num_Ret + 1;
540d8610
ES
3489 Make_Exit_Label;
3490 Rewrite (N,
3491 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
3492
3493 else
3494 if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements
3495 and then Nkind (Parent (Parent (N))) = N_Subprogram_Body
3496 then
3497 -- Function body is a single expression. No need for
3498 -- exit label.
3499
3500 null;
3501
3502 else
3503 Num_Ret := Num_Ret + 1;
3504 Make_Exit_Label;
3505 end if;
3506
3507 -- Because of the presence of private types, the views of the
031936bc
YM
3508 -- expression and the context may be different, so place
3509 -- a type conversion to the context type to avoid spurious
540d8610
ES
3510 -- errors, e.g. when the expression is a numeric literal and
3511 -- the context is private. If the expression is an aggregate,
3512 -- use a qualified expression, because an aggregate is not a
031936bc
YM
3513 -- legal argument of a conversion. Ditto for numeric, character
3514 -- and string literals, and attributes that yield a universal
3515 -- type, because those must be resolved to a specific type.
3516
4a08c95c
AC
3517 if Nkind (Expression (N)) in N_Aggregate
3518 | N_Character_Literal
3519 | N_Null
3520 | N_String_Literal
89a53f83 3521 or else Yields_Universal_Type (Expression (N))
540d8610
ES
3522 then
3523 Ret :=
b849df9a
PT
3524 Make_Qualified_Expression (Loc,
3525 Subtype_Mark => New_Occurrence_Of (Ret_Type, Loc),
3f80a182 3526 Expression => Relocate_Node (Expression (N)));
031936bc
YM
3527
3528 -- Use an unchecked type conversion between access types, for
3529 -- which a type conversion would not always be valid, as no
3530 -- check may result from the conversion.
3531
3532 elsif Is_Access_Type (Ret_Type) then
540d8610
ES
3533 Ret :=
3534 Unchecked_Convert_To
3535 (Ret_Type, Relocate_Node (Expression (N)));
031936bc
YM
3536
3537 -- Otherwise use a type conversion, which may trigger a check
3538
3539 else
3540 Ret :=
b849df9a
PT
3541 Make_Type_Conversion (Loc,
3542 Subtype_Mark => New_Occurrence_Of (Ret_Type, Loc),
031936bc 3543 Expression => Relocate_Node (Expression (N)));
540d8610
ES
3544 end if;
3545
3546 if Nkind (Targ) = N_Defining_Identifier then
3547 Rewrite (N,
3548 Make_Assignment_Statement (Loc,
3549 Name => New_Occurrence_Of (Targ, Loc),
3550 Expression => Ret));
3551 else
3552 Rewrite (N,
3553 Make_Assignment_Statement (Loc,
3554 Name => New_Copy (Targ),
3555 Expression => Ret));
3556 end if;
3557
3558 Set_Assignment_OK (Name (N));
3559
3560 if Present (Exit_Lab) then
3561 Insert_After (N,
3562 Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
3563 end if;
3564 end if;
3565
3566 return OK;
3567
3568 -- An extended return becomes a block whose first statement is the
3569 -- assignment of the initial expression of the return object to the
3570 -- target of the call itself.
3571
3572 elsif Nkind (N) = N_Extended_Return_Statement then
3573 declare
3574 Return_Decl : constant Entity_Id :=
3575 First (Return_Object_Declarations (N));
3576 Assign : Node_Id;
3577
3578 begin
3579 Return_Object := Defining_Identifier (Return_Decl);
3580
3581 if Present (Expression (Return_Decl)) then
3582 if Nkind (Targ) = N_Defining_Identifier then
3583 Assign :=
3584 Make_Assignment_Statement (Loc,
3585 Name => New_Occurrence_Of (Targ, Loc),
3586 Expression => Expression (Return_Decl));
3587 else
3588 Assign :=
3589 Make_Assignment_Statement (Loc,
3590 Name => New_Copy (Targ),
3591 Expression => Expression (Return_Decl));
3592 end if;
3593
3594 Set_Assignment_OK (Name (Assign));
3595
3596 if No (Handled_Statement_Sequence (N)) then
3597 Set_Handled_Statement_Sequence (N,
3598 Make_Handled_Sequence_Of_Statements (Loc,
3599 Statements => New_List));
3600 end if;
3601
3602 Prepend (Assign,
3603 Statements (Handled_Statement_Sequence (N)));
3604 end if;
3605
3606 Rewrite (N,
3607 Make_Block_Statement (Loc,
3608 Handled_Statement_Sequence =>
3609 Handled_Statement_Sequence (N)));
3610
3611 return OK;
3612 end;
3613
3614 -- Remove pragma Unreferenced since it may refer to formals that
3615 -- are not visible in the inlined body, and in any case we will
3616 -- not be posting warnings on the inlined body so it is unneeded.
3617
3618 elsif Nkind (N) = N_Pragma
6e759c2a 3619 and then Pragma_Name (N) = Name_Unreferenced
540d8610 3620 then
b849df9a 3621 Rewrite (N, Make_Null_Statement (Loc));
540d8610
ES
3622 return OK;
3623
3624 else
3625 return OK;
3626 end if;
3627 end Process_Formals;
3628
3629 procedure Replace_Formals is new Traverse_Proc (Process_Formals);
3630
5460389b
ES
3631 --------------------------------
3632 -- Process_Formals_In_Aspects --
3633 --------------------------------
3634
bc1146e5
HK
3635 function Process_Formals_In_Aspects
3636 (N : Node_Id) return Traverse_Result
5460389b 3637 is
5460389b 3638 begin
76bf4321
VI
3639 if Nkind (N) = N_Aspect_Specification then
3640 Replace_Formals (Expression (N));
5460389b
ES
3641 end if;
3642 return OK;
3643 end Process_Formals_In_Aspects;
3644
3645 procedure Replace_Formals_In_Aspects is
bc1146e5 3646 new Traverse_Proc (Process_Formals_In_Aspects);
5460389b 3647
540d8610
ES
3648 ------------------
3649 -- Process_Sloc --
3650 ------------------
3651
3652 function Process_Sloc (Nod : Node_Id) return Traverse_Result is
3653 begin
3654 if not Debug_Generated_Code then
3655 Set_Sloc (Nod, Sloc (N));
3656 Set_Comes_From_Source (Nod, False);
3657 end if;
3658
3659 return OK;
3660 end Process_Sloc;
3661
3662 procedure Reset_Slocs is new Traverse_Proc (Process_Sloc);
3663
3664 ------------------------------
3665 -- Reset_Dispatching_Calls --
3666 ------------------------------
3667
3668 procedure Reset_Dispatching_Calls (N : Node_Id) is
3669
3670 function Do_Reset (N : Node_Id) return Traverse_Result;
540d8610
ES
3671
3672 --------------
3673 -- Do_Reset --
3674 --------------
3675
3676 function Do_Reset (N : Node_Id) return Traverse_Result is
3677 begin
3678 if Nkind (N) = N_Procedure_Call_Statement
3679 and then Nkind (Name (N)) = N_Selected_Component
3680 and then Nkind (Prefix (Name (N))) = N_Identifier
3681 and then Is_Formal (Entity (Prefix (Name (N))))
3682 and then Is_Dispatching_Operation
3683 (Entity (Selector_Name (Name (N))))
3684 then
3685 Set_Entity (Selector_Name (Name (N)), Empty);
3686 end if;
3687
3688 return OK;
3689 end Do_Reset;
3690
f358e5c1 3691 procedure Do_Reset_Calls is new Traverse_Proc (Do_Reset);
540d8610
ES
3692
3693 begin
f358e5c1 3694 Do_Reset_Calls (N);
540d8610
ES
3695 end Reset_Dispatching_Calls;
3696
3697 ---------------------------
3698 -- Rewrite_Function_Call --
3699 ---------------------------
3700
3701 procedure Rewrite_Function_Call (N : Node_Id; Blk : Node_Id) is
3702 HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
3703 Fst : constant Node_Id := First (Statements (HSS));
3704
3705 begin
3706 -- Optimize simple case: function body is a single return statement,
3707 -- which has been expanded into an assignment.
3708
3709 if Is_Empty_List (Declarations (Blk))
3710 and then Nkind (Fst) = N_Assignment_Statement
3711 and then No (Next (Fst))
3712 then
3713 -- The function call may have been rewritten as the temporary
3714 -- that holds the result of the call, in which case remove the
3715 -- now useless declaration.
3716
3717 if Nkind (N) = N_Identifier
3718 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3719 then
3720 Rewrite (Parent (Entity (N)), Make_Null_Statement (Loc));
3721 end if;
3722
3723 Rewrite (N, Expression (Fst));
3724
3725 elsif Nkind (N) = N_Identifier
3726 and then Nkind (Parent (Entity (N))) = N_Object_Declaration
3727 then
3728 -- The block assigns the result of the call to the temporary
3729
3730 Insert_After (Parent (Entity (N)), Blk);
3731
3732 -- If the context is an assignment, and the left-hand side is free of
e5eb84aa 3733 -- side effects, the replacement is also safe.
540d8610
ES
3734
3735 elsif Nkind (Parent (N)) = N_Assignment_Statement
3736 and then
3737 (Is_Entity_Name (Name (Parent (N)))
3738 or else
3739 (Nkind (Name (Parent (N))) = N_Explicit_Dereference
3740 and then Is_Entity_Name (Prefix (Name (Parent (N)))))
3741
3742 or else
3743 (Nkind (Name (Parent (N))) = N_Selected_Component
3744 and then Is_Entity_Name (Prefix (Name (Parent (N))))))
3745 then
3746 -- Replace assignment with the block
3747
3748 declare
3749 Original_Assignment : constant Node_Id := Parent (N);
3750
3751 begin
3752 -- Preserve the original assignment node to keep the complete
3753 -- assignment subtree consistent enough for Analyze_Assignment
3754 -- to proceed (specifically, the original Lhs node must still
3755 -- have an assignment statement as its parent).
3756
3757 -- We cannot rely on Original_Node to go back from the block
3758 -- node to the assignment node, because the assignment might
3759 -- already be a rewrite substitution.
3760
3761 Discard_Node (Relocate_Node (Original_Assignment));
3762 Rewrite (Original_Assignment, Blk);
3763 end;
3764
3765 elsif Nkind (Parent (N)) = N_Object_Declaration then
3766
3767 -- A call to a function which returns an unconstrained type
3768 -- found in the expression initializing an object-declaration is
3769 -- expanded into a procedure call which must be added after the
3770 -- object declaration.
3771
bbab2db3
GD
3772 if Is_Unc_Decl and Back_End_Inlining then
3773 Insert_Action_After (Parent (N), Blk);
3774 else
3775 Set_Expression (Parent (N), Empty);
3776 Insert_After (Parent (N), Blk);
3777 end if;
540d8610 3778
bbab2db3
GD
3779 elsif Is_Unc and then not Back_End_Inlining then
3780 Insert_Before (Parent (N), Blk);
3781 end if;
3782 end Rewrite_Function_Call;
540d8610 3783
540d8610
ES
3784 -- Start of processing for Expand_Inlined_Call
3785
3786 begin
3787 -- Initializations for old/new semantics
3788
d1ec7de5 3789 if not Uses_Back_End then
540d8610
ES
3790 Is_Unc := Is_Array_Type (Etype (Subp))
3791 and then not Is_Constrained (Etype (Subp));
3792 Is_Unc_Decl := False;
3793 else
3794 Is_Unc := Returns_Unconstrained_Type (Subp)
3795 and then Optimization_Level > 0;
3796 Is_Unc_Decl := Nkind (Parent (N)) = N_Object_Declaration
3797 and then Is_Unc;
3798 end if;
3799
3800 -- Check for an illegal attempt to inline a recursive procedure. If the
3801 -- subprogram has parameters this is detected when trying to supply a
3802 -- binding for parameters that already have one. For parameterless
3803 -- subprograms this must be done explicitly.
3804
3805 if In_Open_Scopes (Subp) then
db99c46e
AC
3806 Cannot_Inline
3807 ("cannot inline call to recursive subprogram?", N, Subp);
540d8610
ES
3808 Set_Is_Inlined (Subp, False);
3809 return;
3810
3811 -- Skip inlining if this is not a true inlining since the attribute
09edc2c2
AC
3812 -- Body_To_Inline is also set for renamings (see sinfo.ads). For a
3813 -- true inlining, Orig_Bod has code rather than being an entity.
540d8610
ES
3814
3815 elsif Nkind (Orig_Bod) in N_Entity then
09edc2c2 3816 return;
540d8610
ES
3817 end if;
3818
00bccdf0
PT
3819 if Nkind (Orig_Bod) in N_Defining_Identifier
3820 | N_Defining_Operator_Symbol
540d8610
ES
3821 then
3822 -- Subprogram is renaming_as_body. Calls occurring after the renaming
3823 -- can be replaced with calls to the renamed entity directly, because
3824 -- the subprograms are subtype conformant. If the renamed subprogram
3825 -- is an inherited operation, we must redo the expansion because
3826 -- implicit conversions may be needed. Similarly, if the renamed
3827 -- entity is inlined, expand the call for further optimizations.
3828
3829 Set_Name (N, New_Occurrence_Of (Orig_Bod, Loc));
3830
3831 if Present (Alias (Orig_Bod)) or else Is_Inlined (Orig_Bod) then
3832 Expand_Call (N);
3833 end if;
3834
3835 return;
3836 end if;
3837
3838 -- Register the call in the list of inlined calls
3839
21c51f53 3840 Append_New_Elmt (N, To => Inlined_Calls);
540d8610
ES
3841
3842 -- Use generic machinery to copy body of inlined subprogram, as if it
3843 -- were an instantiation, resetting source locations appropriately, so
3844 -- that nested inlined calls appear in the main unit.
3845
3846 Save_Env (Subp, Empty);
3847 Set_Copied_Sloc_For_Inlined_Body (N, Defining_Entity (Orig_Bod));
3848
3849 -- Old semantics
3850
d1ec7de5 3851 if not Uses_Back_End then
540d8610
ES
3852 declare
3853 Bod : Node_Id;
3854
3855 begin
3856 Bod := Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3857 Blk :=
3858 Make_Block_Statement (Loc,
3f80a182 3859 Declarations => Declarations (Bod),
540d8610
ES
3860 Handled_Statement_Sequence =>
3861 Handled_Statement_Sequence (Bod));
3862
3863 if No (Declarations (Bod)) then
3864 Set_Declarations (Blk, New_List);
3865 end if;
3866
3867 -- For the unconstrained case, capture the name of the local
3868 -- variable that holds the result. This must be the first
3869 -- declaration in the block, because its bounds cannot depend
3870 -- on local variables. Otherwise there is no way to declare the
3871 -- result outside of the block. Needless to say, in general the
3872 -- bounds will depend on the actuals in the call.
3873
3874 -- If the context is an assignment statement, as is the case
3875 -- for the expansion of an extended return, the left-hand side
3876 -- provides bounds even if the return type is unconstrained.
3877
3878 if Is_Unc then
3879 declare
3880 First_Decl : Node_Id;
3881
3882 begin
3883 First_Decl := First (Declarations (Blk));
3884
bbab2db3
GD
3885 -- If the body is a single extended return statement,the
3886 -- resulting block is a nested block.
540d8610 3887
bbab2db3
GD
3888 if No (First_Decl) then
3889 First_Decl :=
3890 First (Statements (Handled_Statement_Sequence (Blk)));
540d8610 3891
bbab2db3
GD
3892 if Nkind (First_Decl) = N_Block_Statement then
3893 First_Decl := First (Declarations (First_Decl));
3894 end if;
3895 end if;
540d8610 3896
bbab2db3 3897 -- No front-end inlining possible
f4ef7b06 3898
bbab2db3
GD
3899 if Nkind (First_Decl) /= N_Object_Declaration then
3900 return;
3901 end if;
540d8610 3902
bbab2db3
GD
3903 if Nkind (Parent (N)) /= N_Assignment_Statement then
3904 Targ1 := Defining_Identifier (First_Decl);
3905 else
3906 Targ1 := Name (Parent (N));
3907 end if;
3908 end;
540d8610 3909 end if;
bbab2db3 3910 end;
540d8610 3911
bbab2db3 3912 -- New semantics
540d8610 3913
bbab2db3
GD
3914 else
3915 declare
3916 Bod : Node_Id;
540d8610 3917
bbab2db3
GD
3918 begin
3919 -- General case
540d8610 3920
bbab2db3
GD
3921 if not Is_Unc then
3922 Bod :=
3923 Copy_Generic_Node (Orig_Bod, Empty, Instantiating => True);
3924 Blk :=
3925 Make_Block_Statement (Loc,
3926 Declarations => Declarations (Bod),
3927 Handled_Statement_Sequence =>
3928 Handled_Statement_Sequence (Bod));
36428cc4 3929
bbab2db3
GD
3930 -- Inline a call to a function that returns an unconstrained type.
3931 -- The semantic analyzer checked that frontend-inlined functions
3932 -- returning unconstrained types have no declarations and have
3933 -- a single extended return statement. As part of its processing
3934 -- the function was split into two subprograms: a procedure P' and
3935 -- a function F' that has a block with a call to procedure P' (see
3936 -- Split_Unconstrained_Function).
3de3a1be 3937
540d8610 3938 else
bbab2db3
GD
3939 pragma Assert
3940 (Nkind
3941 (First
3942 (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
3943 N_Block_Statement);
3de3a1be 3944
bbab2db3
GD
3945 declare
3946 Blk_Stmt : constant Node_Id :=
3947 First (Statements (Handled_Statement_Sequence (Orig_Bod)));
3948 First_Stmt : constant Node_Id :=
3949 First (Statements (Handled_Statement_Sequence (Blk_Stmt)));
3950 Second_Stmt : constant Node_Id := Next (First_Stmt);
72cdccfa 3951
bbab2db3
GD
3952 begin
3953 pragma Assert
3954 (Nkind (First_Stmt) = N_Procedure_Call_Statement
3955 and then Nkind (Second_Stmt) = N_Simple_Return_Statement
3956 and then No (Next (Second_Stmt)));
3de3a1be 3957
bbab2db3
GD
3958 Bod :=
3959 Copy_Generic_Node
3960 (First
3961 (Statements (Handled_Statement_Sequence (Orig_Bod))),
3962 Empty, Instantiating => True);
3963 Blk := Bod;
3964
3965 -- Capture the name of the local variable that holds the
3966 -- result. This must be the first declaration in the block,
3967 -- because its bounds cannot depend on local variables.
3968 -- Otherwise there is no way to declare the result outside
3969 -- of the block. Needless to say, in general the bounds will
3970 -- depend on the actuals in the call.
3971
3972 if Nkind (Parent (N)) /= N_Assignment_Statement then
3973 Targ1 := Defining_Identifier (First (Declarations (Blk)));
3974
3975 -- If the context is an assignment statement, as is the case
3976 -- for the expansion of an extended return, the left-hand
3977 -- side provides bounds even if the return type is
3978 -- unconstrained.
3979
3980 else
3981 Targ1 := Name (Parent (N));
3982 end if;
3983 end;
540d8610
ES
3984 end if;
3985
bbab2db3
GD
3986 if No (Declarations (Bod)) then
3987 Set_Declarations (Blk, New_List);
3988 end if;
3989 end;
3990 end if;
540d8610 3991
bbab2db3
GD
3992 -- If this is a derived function, establish the proper return type
3993
3994 if Present (Orig_Subp) and then Orig_Subp /= Subp then
3995 Ret_Type := Etype (Orig_Subp);
3996 else
3997 Ret_Type := Etype (Subp);
3998 end if;
3999
4000 -- Create temporaries for the actuals that are expressions, or that are
4001 -- scalars and require copying to preserve semantics.
4002
4003 Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Orig_Bod);
540d8610
ES
4004
4005 -- Establish target of function call. If context is not assignment or
4006 -- declaration, create a temporary as a target. The declaration for the
4007 -- temporary may be subsequently optimized away if the body is a single
4008 -- expression, or if the left-hand side of the assignment is simple
4009 -- enough, i.e. an entity or an explicit dereference of one.
4010
4011 if Ekind (Subp) = E_Function then
4012 if Nkind (Parent (N)) = N_Assignment_Statement
4013 and then Is_Entity_Name (Name (Parent (N)))
4014 then
4015 Targ := Name (Parent (N));
4016
4017 elsif Nkind (Parent (N)) = N_Assignment_Statement
4018 and then Nkind (Name (Parent (N))) = N_Explicit_Dereference
4019 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4020 then
4021 Targ := Name (Parent (N));
4022
4023 elsif Nkind (Parent (N)) = N_Assignment_Statement
4024 and then Nkind (Name (Parent (N))) = N_Selected_Component
4025 and then Is_Entity_Name (Prefix (Name (Parent (N))))
4026 then
4027 Targ := New_Copy_Tree (Name (Parent (N)));
4028
4029 elsif Nkind (Parent (N)) = N_Object_Declaration
4030 and then Is_Limited_Type (Etype (Subp))
4031 then
4032 Targ := Defining_Identifier (Parent (N));
4033
4034 -- New semantics: In an object declaration avoid an extra copy
4035 -- of the result of a call to an inlined function that returns
4036 -- an unconstrained type
4037
d1ec7de5 4038 elsif Uses_Back_End
540d8610
ES
4039 and then Nkind (Parent (N)) = N_Object_Declaration
4040 and then Is_Unc
4041 then
4042 Targ := Defining_Identifier (Parent (N));
4043
4044 else
4045 -- Replace call with temporary and create its declaration
4046
4047 Temp := Make_Temporary (Loc, 'C');
5a8191d7 4048 Mutate_Ekind (Temp, E_Constant);
540d8610
ES
4049 Set_Is_Internal (Temp);
4050
4051 -- For the unconstrained case, the generated temporary has the
4052 -- same constrained declaration as the result variable. It may
4053 -- eventually be possible to remove that temporary and use the
4054 -- result variable directly.
4055
3f80a182 4056 if Is_Unc and then Nkind (Parent (N)) /= N_Assignment_Statement
540d8610
ES
4057 then
4058 Decl :=
4059 Make_Object_Declaration (Loc,
4060 Defining_Identifier => Temp,
4061 Object_Definition =>
4062 New_Copy_Tree (Object_Definition (Parent (Targ1))));
4063
4064 Replace_Formals (Decl);
4065
4066 else
4067 Decl :=
4068 Make_Object_Declaration (Loc,
4069 Defining_Identifier => Temp,
4070 Object_Definition => New_Occurrence_Of (Ret_Type, Loc));
4071
4072 Set_Etype (Temp, Ret_Type);
4073 end if;
4074
4075 Set_No_Initialization (Decl);
4076 Append (Decl, Decls);
4077 Rewrite (N, New_Occurrence_Of (Temp, Loc));
4078 Targ := Temp;
4079 end if;
4080 end if;
4081
4082 Insert_Actions (N, Decls);
4083
4084 if Is_Unc_Decl then
4085
4086 -- Special management for inlining a call to a function that returns
4087 -- an unconstrained type and initializes an object declaration: we
4088 -- avoid generating undesired extra calls and goto statements.
4089
4090 -- Given:
66f95f60 4091 -- function Func (...) return String is
540d8610
ES
4092 -- begin
4093 -- declare
4094 -- Result : String (1 .. 4);
4095 -- begin
4096 -- Proc (Result, ...);
4097 -- return Result;
4098 -- end;
66f95f60 4099 -- end Func;
540d8610
ES
4100
4101 -- Result : String := Func (...);
4102
4103 -- Replace this object declaration by:
4104
4105 -- Result : String (1 .. 4);
4106 -- Proc (Result, ...);
4107
4108 Remove_Homonym (Targ);
4109
4110 Decl :=
4111 Make_Object_Declaration
4112 (Loc,
4113 Defining_Identifier => Targ,
4114 Object_Definition =>
4115 New_Copy_Tree (Object_Definition (Parent (Targ1))));
4116 Replace_Formals (Decl);
b96446e0 4117 Set_No_Initialization (Decl);
540d8610
ES
4118 Rewrite (Parent (N), Decl);
4119 Analyze (Parent (N));
4120
4121 -- Avoid spurious warnings since we know that this declaration is
4122 -- referenced by the procedure call.
4123
4124 Set_Never_Set_In_Source (Targ, False);
4125
4126 -- Remove the local declaration of the extended return stmt from the
4127 -- inlined code
4128
4129 Remove (Parent (Targ1));
4130
4131 -- Update the reference to the result (since we have rewriten the
4132 -- object declaration)
4133
4134 declare
4135 Blk_Call_Stmt : Node_Id;
4136
4137 begin
4138 -- Capture the call to the procedure
4139
4140 Blk_Call_Stmt :=
4141 First (Statements (Handled_Statement_Sequence (Blk)));
4142 pragma Assert
4143 (Nkind (Blk_Call_Stmt) = N_Procedure_Call_Statement);
4144
4145 Remove (First (Parameter_Associations (Blk_Call_Stmt)));
4146 Prepend_To (Parameter_Associations (Blk_Call_Stmt),
4147 New_Occurrence_Of (Targ, Loc));
4148 end;
4149
4150 -- Remove the return statement
4151
4152 pragma Assert
4153 (Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
4154 N_Simple_Return_Statement);
4155
4156 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
4157 end if;
4158
4159 -- Traverse the tree and replace formals with actuals or their thunks.
4160 -- Attach block to tree before analysis and rewriting.
4161
4162 Replace_Formals (Blk);
5460389b 4163 Replace_Formals_In_Aspects (Blk);
540d8610
ES
4164 Set_Parent (Blk, N);
4165
e5c4e2bc
AC
4166 if GNATprove_Mode then
4167 null;
4168
4169 elsif not Comes_From_Source (Subp) or else Is_Predef then
540d8610
ES
4170 Reset_Slocs (Blk);
4171 end if;
4172
4173 if Is_Unc_Decl then
4174
4175 -- No action needed since return statement has been already removed
4176
4177 null;
4178
4179 elsif Present (Exit_Lab) then
4180
fae8eb5b
GD
4181 -- If there's a single return statement at the end of the subprogram,
4182 -- the corresponding goto statement and the corresponding label are
4183 -- useless.
540d8610
ES
4184
4185 if Num_Ret = 1
4186 and then
4187 Nkind (Last (Statements (Handled_Statement_Sequence (Blk)))) =
4188 N_Goto_Statement
4189 then
4190 Remove (Last (Statements (Handled_Statement_Sequence (Blk))));
4191 else
4192 Append (Lab_Decl, (Declarations (Blk)));
4193 Append (Exit_Lab, Statements (Handled_Statement_Sequence (Blk)));
4194 end if;
4195 end if;
4196
4197 -- Analyze Blk with In_Inlined_Body set, to avoid spurious errors
4198 -- on conflicting private views that Gigi would ignore. If this is a
4199 -- predefined unit, analyze with checks off, as is done in the non-
4200 -- inlined run-time units.
4201
4202 declare
4203 I_Flag : constant Boolean := In_Inlined_Body;
4204
4205 begin
4206 In_Inlined_Body := True;
4207
4208 if Is_Predef then
4209 declare
4210 Style : constant Boolean := Style_Check;
4211
4212 begin
4213 Style_Check := False;
4214
4215 -- Search for dispatching calls that use the Object.Operation
4216 -- notation using an Object that is a parameter of the inlined
4217 -- function. We reset the decoration of Operation to force
4218 -- the reanalysis of the inlined dispatching call because
4219 -- the actual object has been inlined.
4220
4221 Reset_Dispatching_Calls (Blk);
4222
9ff488f0
YM
4223 -- In GNATprove mode, always consider checks on, even for
4224 -- predefined units.
4225
4226 if GNATprove_Mode then
4227 Analyze (Blk);
4228 else
4229 Analyze (Blk, Suppress => All_Checks);
4230 end if;
4231
540d8610
ES
4232 Style_Check := Style;
4233 end;
4234
4235 else
4236 Analyze (Blk);
4237 end if;
4238
4239 In_Inlined_Body := I_Flag;
4240 end;
4241
4242 if Ekind (Subp) = E_Procedure then
2bf7943f 4243 Rewrite (N, Blk);
540d8610
ES
4244
4245 else
4246 Rewrite_Function_Call (N, Blk);
4247
4248 if Is_Unc_Decl then
4249 null;
4250
4251 -- For the unconstrained case, the replacement of the call has been
4252 -- made prior to the complete analysis of the generated declarations.
4253 -- Propagate the proper type now.
4254
4255 elsif Is_Unc then
4256 if Nkind (N) = N_Identifier then
4257 Set_Etype (N, Etype (Entity (N)));
4258 else
4259 Set_Etype (N, Etype (Targ1));
4260 end if;
4261 end if;
4262 end if;
4263
4264 Restore_Env;
4265
4266 -- Cleanup mapping between formals and actuals for other expansions
4267
bbab2db3 4268 Reset_Actual_Mapping_For_Inlined_Call (Subp);
540d8610 4269 end Expand_Inlined_Call;
3f80a182 4270
70c34e1c
AC
4271 --------------------------
4272 -- Get_Code_Unit_Entity --
4273 --------------------------
4274
4275 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
8a49a499 4276 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
5b5b27ad 4277
70c34e1c 4278 begin
8a49a499
AC
4279 if Ekind (Unit) = E_Package_Body then
4280 Unit := Spec_Entity (Unit);
4281 end if;
5b5b27ad 4282
8a49a499 4283 return Unit;
70c34e1c
AC
4284 end Get_Code_Unit_Entity;
4285
6c26bac2
AC
4286 ------------------------------
4287 -- Has_Excluded_Declaration --
4288 ------------------------------
4289
4290 function Has_Excluded_Declaration
4291 (Subp : Entity_Id;
4292 Decls : List_Id) return Boolean
4293 is
6c26bac2
AC
4294 function Is_Unchecked_Conversion (D : Node_Id) return Boolean;
4295 -- Nested subprograms make a given body ineligible for inlining, but
4296 -- we make an exception for instantiations of unchecked conversion.
4297 -- The body has not been analyzed yet, so check the name, and verify
4298 -- that the visible entity with that name is the predefined unit.
4299
4300 -----------------------------
4301 -- Is_Unchecked_Conversion --
4302 -----------------------------
4303
4304 function Is_Unchecked_Conversion (D : Node_Id) return Boolean is
4305 Id : constant Node_Id := Name (D);
4306 Conv : Entity_Id;
4307
4308 begin
4309 if Nkind (Id) = N_Identifier
4310 and then Chars (Id) = Name_Unchecked_Conversion
4311 then
4312 Conv := Current_Entity (Id);
4313
4a08c95c 4314 elsif Nkind (Id) in N_Selected_Component | N_Expanded_Name
6c26bac2
AC
4315 and then Chars (Selector_Name (Id)) = Name_Unchecked_Conversion
4316 then
4317 Conv := Current_Entity (Selector_Name (Id));
4318 else
4319 return False;
4320 end if;
4321
4322 return Present (Conv)
8ab31c0c 4323 and then Is_Predefined_Unit (Get_Source_Unit (Conv))
6c26bac2
AC
4324 and then Is_Intrinsic_Subprogram (Conv);
4325 end Is_Unchecked_Conversion;
4326
3613473a
PT
4327 -- Local variables
4328
4329 Decl : Node_Id;
4330
6c26bac2
AC
4331 -- Start of processing for Has_Excluded_Declaration
4332
4333 begin
16b10ccc
AC
4334 -- No action needed if the check is not needed
4335
4336 if not Check_Inlining_Restrictions then
4337 return False;
4338 end if;
4339
3613473a
PT
4340 Decl := First (Decls);
4341 while Present (Decl) loop
3c756b76 4342
6fd52b78
AC
4343 -- First declarations universally excluded
4344
3613473a 4345 if Nkind (Decl) = N_Package_Declaration then
6c26bac2 4346 Cannot_Inline
3613473a 4347 ("cannot inline & (nested package declaration)?", Decl, Subp);
6fd52b78
AC
4348 return True;
4349
3613473a 4350 elsif Nkind (Decl) = N_Package_Instantiation then
6fd52b78 4351 Cannot_Inline
3613473a 4352 ("cannot inline & (nested package instantiation)?", Decl, Subp);
6c26bac2 4353 return True;
6fd52b78
AC
4354 end if;
4355
66f95f60 4356 -- Then declarations excluded only for front-end inlining
6fd52b78
AC
4357
4358 if Back_End_Inlining then
4359 null;
6c26bac2 4360
3613473a
PT
4361 elsif Nkind (Decl) = N_Task_Type_Declaration
4362 or else Nkind (Decl) = N_Single_Task_Declaration
6c26bac2
AC
4363 then
4364 Cannot_Inline
3613473a 4365 ("cannot inline & (nested task type declaration)?", Decl, Subp);
6c26bac2
AC
4366 return True;
4367
3613473a
PT
4368 elsif Nkind (Decl) in N_Protected_Type_Declaration
4369 | N_Single_Protected_Declaration
6c26bac2
AC
4370 then
4371 Cannot_Inline
4372 ("cannot inline & (nested protected type declaration)?",
3613473a 4373 Decl, Subp);
6c26bac2
AC
4374 return True;
4375
3613473a 4376 elsif Nkind (Decl) = N_Subprogram_Body then
6c26bac2 4377 Cannot_Inline
3613473a 4378 ("cannot inline & (nested subprogram)?", Decl, Subp);
6c26bac2
AC
4379 return True;
4380
3613473a
PT
4381 elsif Nkind (Decl) = N_Function_Instantiation
4382 and then not Is_Unchecked_Conversion (Decl)
6c26bac2
AC
4383 then
4384 Cannot_Inline
3613473a 4385 ("cannot inline & (nested function instantiation)?", Decl, Subp);
6c26bac2
AC
4386 return True;
4387
3613473a 4388 elsif Nkind (Decl) = N_Procedure_Instantiation then
6c26bac2 4389 Cannot_Inline
3613473a
PT
4390 ("cannot inline & (nested procedure instantiation)?",
4391 Decl, Subp);
6c26bac2 4392 return True;
f99ff327
AC
4393
4394 -- Subtype declarations with predicates will generate predicate
4395 -- functions, i.e. nested subprogram bodies, so inlining is not
4396 -- possible.
4397
71a4bdad 4398 elsif Nkind (Decl) = N_Subtype_Declaration then
f99ff327
AC
4399 declare
4400 A : Node_Id;
4401 A_Id : Aspect_Id;
4402
4403 begin
3613473a 4404 A := First (Aspect_Specifications (Decl));
f99ff327
AC
4405 while Present (A) loop
4406 A_Id := Get_Aspect_Id (Chars (Identifier (A)));
4407
4408 if A_Id = Aspect_Predicate
4409 or else A_Id = Aspect_Static_Predicate
4410 or else A_Id = Aspect_Dynamic_Predicate
4411 then
4412 Cannot_Inline
ca7e6c26 4413 ("cannot inline & (subtype declaration with "
3613473a 4414 & "predicate)?", Decl, Subp);
f99ff327
AC
4415 return True;
4416 end if;
4417
4418 Next (A);
4419 end loop;
4420 end;
6c26bac2
AC
4421 end if;
4422
3613473a 4423 Next (Decl);
6c26bac2
AC
4424 end loop;
4425
4426 return False;
4427 end Has_Excluded_Declaration;
4428
4429 ----------------------------
4430 -- Has_Excluded_Statement --
4431 ----------------------------
4432
4433 function Has_Excluded_Statement
4434 (Subp : Entity_Id;
4435 Stats : List_Id) return Boolean
4436 is
4437 S : Node_Id;
4438 E : Node_Id;
4439
4440 begin
16b10ccc
AC
4441 -- No action needed if the check is not needed
4442
4443 if not Check_Inlining_Restrictions then
4444 return False;
4445 end if;
4446
6c26bac2
AC
4447 S := First (Stats);
4448 while Present (S) loop
4a08c95c
AC
4449 if Nkind (S) in N_Abort_Statement
4450 | N_Asynchronous_Select
4451 | N_Conditional_Entry_Call
4452 | N_Delay_Relative_Statement
4453 | N_Delay_Until_Statement
4454 | N_Selective_Accept
4455 | N_Timed_Entry_Call
6c26bac2
AC
4456 then
4457 Cannot_Inline
4458 ("cannot inline & (non-allowed statement)?", S, Subp);
4459 return True;
4460
4461 elsif Nkind (S) = N_Block_Statement then
d7f5bfe4 4462 if Has_Excluded_Declaration (Subp, Declarations (S)) then
6c26bac2
AC
4463 return True;
4464
4465 elsif Present (Handled_Statement_Sequence (S)) then
16b10ccc
AC
4466 if not Back_End_Inlining
4467 and then
4468 Present
4469 (Exception_Handlers (Handled_Statement_Sequence (S)))
6c26bac2
AC
4470 then
4471 Cannot_Inline
4472 ("cannot inline& (exception handler)?",
4473 First (Exception_Handlers
4474 (Handled_Statement_Sequence (S))),
4475 Subp);
4476 return True;
4477
4478 elsif Has_Excluded_Statement
4479 (Subp, Statements (Handled_Statement_Sequence (S)))
4480 then
4481 return True;
4482 end if;
4483 end if;
4484
4485 elsif Nkind (S) = N_Case_Statement then
4486 E := First (Alternatives (S));
4487 while Present (E) loop
4488 if Has_Excluded_Statement (Subp, Statements (E)) then
4489 return True;
4490 end if;
4491
4492 Next (E);
4493 end loop;
4494
4495 elsif Nkind (S) = N_If_Statement then
4496 if Has_Excluded_Statement (Subp, Then_Statements (S)) then
4497 return True;
4498 end if;
4499
4500 if Present (Elsif_Parts (S)) then
4501 E := First (Elsif_Parts (S));
4502 while Present (E) loop
4503 if Has_Excluded_Statement (Subp, Then_Statements (E)) then
4504 return True;
4505 end if;
4506
4507 Next (E);
4508 end loop;
4509 end if;
4510
4511 if Present (Else_Statements (S))
4512 and then Has_Excluded_Statement (Subp, Else_Statements (S))
4513 then
4514 return True;
4515 end if;
4516
4517 elsif Nkind (S) = N_Loop_Statement
4518 and then Has_Excluded_Statement (Subp, Statements (S))
4519 then
4520 return True;
4521
4522 elsif Nkind (S) = N_Extended_Return_Statement then
4523 if Present (Handled_Statement_Sequence (S))
4524 and then
4525 Has_Excluded_Statement
4526 (Subp, Statements (Handled_Statement_Sequence (S)))
4527 then
4528 return True;
4529
16b10ccc
AC
4530 elsif not Back_End_Inlining
4531 and then Present (Handled_Statement_Sequence (S))
6c26bac2
AC
4532 and then
4533 Present (Exception_Handlers
4534 (Handled_Statement_Sequence (S)))
4535 then
4536 Cannot_Inline
4537 ("cannot inline& (exception handler)?",
4538 First (Exception_Handlers (Handled_Statement_Sequence (S))),
4539 Subp);
4540 return True;
4541 end if;
4542 end if;
4543
4544 Next (S);
4545 end loop;
4546
4547 return False;
4548 end Has_Excluded_Statement;
4549
38cbfe40
RK
4550 --------------------------
4551 -- Has_Initialized_Type --
4552 --------------------------
4553
4554 function Has_Initialized_Type (E : Entity_Id) return Boolean is
90a4b336 4555 E_Body : constant Node_Id := Subprogram_Body (E);
38cbfe40
RK
4556 Decl : Node_Id;
4557
4558 begin
6d16658d 4559 if No (E_Body) then -- imported subprogram
38cbfe40
RK
4560 return False;
4561
4562 else
4563 Decl := First (Declarations (E_Body));
38cbfe40 4564 while Present (Decl) loop
38cbfe40 4565 if Nkind (Decl) = N_Full_Type_Declaration
6d16658d 4566 and then Comes_From_Source (Decl)
38cbfe40
RK
4567 and then Present (Init_Proc (Defining_Identifier (Decl)))
4568 then
4569 return True;
4570 end if;
4571
4572 Next (Decl);
4573 end loop;
4574 end if;
4575
4576 return False;
4577 end Has_Initialized_Type;
4578
ea0c8cfb
RD
4579 -----------------------
4580 -- Has_Single_Return --
4581 -----------------------
6c26bac2
AC
4582
4583 function Has_Single_Return (N : Node_Id) return Boolean is
4584 Return_Statement : Node_Id := Empty;
4585
4586 function Check_Return (N : Node_Id) return Traverse_Result;
4587
4588 ------------------
4589 -- Check_Return --
4590 ------------------
4591
4592 function Check_Return (N : Node_Id) return Traverse_Result is
4593 begin
4594 if Nkind (N) = N_Simple_Return_Statement then
4595 if Present (Expression (N))
4596 and then Is_Entity_Name (Expression (N))
4597 then
3ac5f7de
JM
4598 pragma Assert (Present (Entity (Expression (N))));
4599
6c26bac2
AC
4600 if No (Return_Statement) then
4601 Return_Statement := N;
4602 return OK;
4603
6c26bac2 4604 else
3ac5f7de
JM
4605 pragma Assert
4606 (Present (Entity (Expression (Return_Statement))));
4607
4608 if Entity (Expression (N)) =
4609 Entity (Expression (Return_Statement))
4610 then
4611 return OK;
4612 else
4613 return Abandon;
4614 end if;
6c26bac2
AC
4615 end if;
4616
400ad4e9
HK
4617 -- A return statement within an extended return is a noop after
4618 -- inlining.
6c26bac2
AC
4619
4620 elsif No (Expression (N))
400ad4e9
HK
4621 and then Nkind (Parent (Parent (N))) =
4622 N_Extended_Return_Statement
6c26bac2
AC
4623 then
4624 return OK;
4625
4626 else
4627 -- Expression has wrong form
4628
4629 return Abandon;
4630 end if;
4631
ea0c8cfb
RD
4632 -- We can only inline a build-in-place function if it has a single
4633 -- extended return.
6c26bac2
AC
4634
4635 elsif Nkind (N) = N_Extended_Return_Statement then
4636 if No (Return_Statement) then
4637 Return_Statement := N;
4638 return OK;
4639
4640 else
4641 return Abandon;
4642 end if;
4643
4644 else
4645 return OK;
4646 end if;
4647 end Check_Return;
4648
4649 function Check_All_Returns is new Traverse_Func (Check_Return);
4650
4651 -- Start of processing for Has_Single_Return
4652
4653 begin
4654 if Check_All_Returns (N) /= OK then
4655 return False;
4656
4657 elsif Nkind (Return_Statement) = N_Extended_Return_Statement then
4658 return True;
4659
4660 else
400ad4e9 4661 return
33f560e2 4662 Present (First (Declarations (N)))
d03a7f8c 4663 and then Nkind (First (Declarations (N))) = N_Object_Declaration
400ad4e9
HK
4664 and then Entity (Expression (Return_Statement)) =
4665 Defining_Identifier (First (Declarations (N)));
6c26bac2
AC
4666 end if;
4667 end Has_Single_Return;
4668
5b5b27ad
AC
4669 -----------------------------
4670 -- In_Main_Unit_Or_Subunit --
4671 -----------------------------
4672
4673 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is
4674 Comp : Node_Id := Cunit (Get_Code_Unit (E));
4675
4676 begin
4677 -- Check whether the subprogram or package to inline is within the main
4678 -- unit or its spec or within a subunit. In either case there are no
4679 -- additional bodies to process. If the subprogram appears in a parent
4680 -- of the current unit, the check on whether inlining is possible is
4681 -- done in Analyze_Inlined_Bodies.
4682
4683 while Nkind (Unit (Comp)) = N_Subunit loop
16007e34 4684 Comp := Subunit_Parent (Comp);
5b5b27ad
AC
4685 end loop;
4686
4687 return Comp = Cunit (Main_Unit)
492f9cdf 4688 or else Comp = Other_Comp_Unit (Cunit (Main_Unit));
5b5b27ad
AC
4689 end In_Main_Unit_Or_Subunit;
4690
38cbfe40
RK
4691 ----------------
4692 -- Initialize --
4693 ----------------
4694
4695 procedure Initialize is
4696 begin
38cbfe40 4697 Pending_Instantiations.Init;
92b635e5 4698 Called_Pending_Instantiations.Init;
38cbfe40
RK
4699 Inlined_Bodies.Init;
4700 Successors.Init;
4701 Inlined.Init;
4702
4703 for J in Hash_Headers'Range loop
4704 Hash_Headers (J) := No_Subp;
4705 end loop;
16b10ccc
AC
4706
4707 Inlined_Calls := No_Elist;
4708 Backend_Calls := No_Elist;
4b96d386 4709 Backend_Instances := No_Elist;
16b10ccc
AC
4710 Backend_Inlined_Subps := No_Elist;
4711 Backend_Not_Inlined_Subps := No_Elist;
38cbfe40
RK
4712 end Initialize;
4713
8cd5951d
AC
4714 ---------------------------------
4715 -- Inline_Static_Function_Call --
4716 ---------------------------------
bbab2db3 4717
8cd5951d 4718 procedure Inline_Static_Function_Call (N : Node_Id; Subp : Entity_Id) is
bbab2db3
GD
4719
4720 function Replace_Formal (N : Node_Id) return Traverse_Result;
d644c519
PT
4721 -- Replace each occurrence of a formal with the
4722 -- corresponding actual, using the mapping created
4723 -- by Establish_Actual_Mapping_For_Inlined_Call.
bbab2db3
GD
4724
4725 function Reset_Sloc (Nod : Node_Id) return Traverse_Result;
4726 -- Reset the Sloc of a node to that of the call itself, so that errors
4727 -- will be flagged on the call to the static expression function itself
4728 -- rather than on the expression of the function's declaration.
4729
4730 --------------------
4731 -- Replace_Formal --
4732 --------------------
4733
4734 function Replace_Formal (N : Node_Id) return Traverse_Result is
35f29cfe
PT
4735 A : Entity_Id;
4736 E : Entity_Id;
bbab2db3
GD
4737
4738 begin
4739 if Is_Entity_Name (N) and then Present (Entity (N)) then
4740 E := Entity (N);
4741
4742 if Is_Formal (E) and then Scope (E) = Subp then
4743 A := Renamed_Object (E);
4744
4745 if Nkind (A) = N_Defining_Identifier then
4746 Rewrite (N, New_Occurrence_Of (A, Sloc (N)));
4747
4748 -- Literal cases
4749
4750 else
4751 Rewrite (N, New_Copy (A));
4752 end if;
4753 end if;
4754
4755 return Skip;
4756
4757 else
4758 return OK;
4759 end if;
4760 end Replace_Formal;
4761
4762 procedure Replace_Formals is new Traverse_Proc (Replace_Formal);
4763
4764 ------------------
4765 -- Process_Sloc --
4766 ------------------
4767
4768 function Reset_Sloc (Nod : Node_Id) return Traverse_Result is
4769 begin
4770 Set_Sloc (Nod, Sloc (N));
4771 Set_Comes_From_Source (Nod, False);
4772
4773 return OK;
4774 end Reset_Sloc;
4775
4776 procedure Reset_Slocs is new Traverse_Proc (Reset_Sloc);
4777
8cd5951d 4778 -- Start of processing for Inline_Static_Function_Call
bbab2db3
GD
4779
4780 begin
8cd5951d 4781 pragma Assert (Is_Static_Function_Call (N));
bbab2db3
GD
4782
4783 declare
4784 Decls : constant List_Id := New_List;
4785 Func_Expr : constant Node_Id :=
4786 Expression_Of_Expression_Function (Subp);
4787 Expr_Copy : constant Node_Id := New_Copy_Tree (Func_Expr);
4788
4789 begin
4790 -- Create a mapping from formals to actuals, also creating temps in
4791 -- Decls, when needed, to hold the actuals.
4792
4793 Establish_Actual_Mapping_For_Inlined_Call (N, Subp, Decls, Func_Expr);
4794
85f6d7e2
GD
4795 -- Ensure that the copy has the same parent as the call (this seems
4796 -- to matter when GNATprove_Mode is set and there are nested static
4797 -- calls; prevents blowups in Insert_Actions, though it's not clear
4798 -- exactly why this is needed???).
4799
4800 Set_Parent (Expr_Copy, Parent (N));
4801
bbab2db3
GD
4802 Insert_Actions (N, Decls);
4803
4804 -- Now substitute actuals for their corresponding formal references
4805 -- within the expression.
4806
4807 Replace_Formals (Expr_Copy);
4808
4809 Reset_Slocs (Expr_Copy);
4810
4811 -- Apply a qualified expression with the function's result subtype,
4812 -- to ensure that we check the expression against any constraint
4813 -- or predicate, which will cause the call to be illegal if the
4814 -- folded expression doesn't satisfy them. (The predicate case
4815 -- might not get checked if the subtype hasn't been frozen yet,
4816 -- which can happen if this static expression happens to be what
4817 -- causes the freezing, because Has_Static_Predicate doesn't get
4818 -- set on the subtype until it's frozen and Build_Predicates is
4819 -- called. It's not clear how to address this case. ???)
4820
4821 Rewrite (Expr_Copy,
4822 Make_Qualified_Expression (Sloc (Expr_Copy),
4823 Subtype_Mark =>
4824 New_Occurrence_Of (Etype (N), Sloc (Expr_Copy)),
4825 Expression =>
4826 Relocate_Node (Expr_Copy)));
4827
4828 Set_Etype (Expr_Copy, Etype (N));
4829
4830 Analyze_And_Resolve (Expr_Copy, Etype (N));
4831
4832 -- Finally rewrite the function call as the folded static result
4833
4834 Rewrite (N, Expr_Copy);
4835
4836 -- Cleanup mapping between formals and actuals for other expansions
4837
4838 Reset_Actual_Mapping_For_Inlined_Call (Subp);
4839 end;
8cd5951d 4840 end Inline_Static_Function_Call;
bbab2db3 4841
38cbfe40
RK
4842 ------------------------
4843 -- Instantiate_Bodies --
4844 ------------------------
4845
4846 -- Generic bodies contain all the non-local references, so an
4847 -- instantiation does not need any more context than Standard
4848 -- itself, even if the instantiation appears in an inner scope.
4849 -- Generic associations have verified that the contract model is
4850 -- satisfied, so that any error that may occur in the analysis of
4851 -- the body is an internal error.
4852
4853 procedure Instantiate_Bodies is
4b96d386
EB
4854
4855 procedure Instantiate_Body (Info : Pending_Body_Info);
4856 -- Instantiate a pending body
4857
4858 ------------------------
4859 -- Instantiate_Body --
4860 ------------------------
4861
4862 procedure Instantiate_Body (Info : Pending_Body_Info) is
0c1d2675
EB
4863 Scop : Entity_Id;
4864
4b96d386
EB
4865 begin
4866 -- If the instantiation node is absent, it has been removed as part
4867 -- of unreachable code.
4868
4869 if No (Info.Inst_Node) then
4870 null;
4871
6c87c83b
EB
4872 -- If the instantiation node is a package body, this means that the
4873 -- instance is a compilation unit and the instantiation has already
4874 -- been performed by Build_Instance_Compilation_Unit_Nodes.
4875
4876 elsif Nkind (Info.Inst_Node) = N_Package_Body then
4877 null;
4878
0c1d2675
EB
4879 -- For other package instances, instantiate the body and register the
4880 -- finalization scope, if any, for subsequent generation of cleanups.
4881
4882 elsif Nkind (Info.Inst_Node) = N_Package_Instantiation then
4883
4884 -- If the enclosing finalization scope is a package body, set the
4885 -- In_Package_Body flag on its spec. This is required, in the case
4886 -- where the body contains other package instantiations that have
4887 -- a body, for Analyze_Package_Instantiation to compute a correct
4888 -- finalization scope.
4889
4890 if Present (Info.Fin_Scop)
4891 and then Ekind (Info.Fin_Scop) = E_Package_Body
4892 then
4893 Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), True);
1f6b0d91
EB
4894 Instantiate_Package_Body (Info);
4895 Set_In_Package_Body (Spec_Entity (Info.Fin_Scop), False);
4896 else
4897 Instantiate_Package_Body (Info);
0c1d2675
EB
4898 end if;
4899
1f6b0d91 4900 -- No need to generate cleanups if the main unit is generic
0c1d2675 4901
1f6b0d91
EB
4902 if Present (Info.Fin_Scop)
4903 and then not Is_Generic_Unit (Main_Unit_Entity)
4904 then
0c1d2675
EB
4905 Scop := Info.Fin_Scop;
4906
4907 -- If the enclosing finalization scope is dynamic, the instance
4908 -- may have been relocated, for example if it was declared in a
4909 -- protected entry, protected subprogram, or task body.
4910
4911 if Is_Dynamic_Scope (Scop) then
4912 Scop :=
4913 Enclosing_Dynamic_Scope (Defining_Entity (Info.Act_Decl));
4914 end if;
4915
4916 Add_Scope_To_Clean (Scop);
0c1d2675
EB
4917 end if;
4918
4919 -- For subprogram instances, always instantiate the body
4b96d386
EB
4920
4921 else
4922 Instantiate_Subprogram_Body (Info);
4923 end if;
4924 end Instantiate_Body;
4925
6feab95c 4926 J, K : Nat;
38cbfe40
RK
4927 Info : Pending_Body_Info;
4928
4b96d386
EB
4929 -- Start of processing for Instantiate_Bodies
4930
38cbfe40 4931 begin
07fc65c4 4932 if Serious_Errors_Detected = 0 then
fbf5a39b 4933 Expander_Active := (Operating_Mode = Opt.Generate_Code);
a99ada67 4934 Push_Scope (Standard_Standard);
38cbfe40
RK
4935 To_Clean := New_Elmt_List;
4936
38cbfe40
RK
4937 -- A body instantiation may generate additional instantiations, so
4938 -- the following loop must scan to the end of a possibly expanding
4b96d386
EB
4939 -- set (that's why we cannot simply use a FOR loop here). We must
4940 -- also capture the element lest the set be entirely reallocated.
38cbfe40
RK
4941
4942 J := 0;
4b96d386
EB
4943 if Back_End_Inlining then
4944 while J <= Called_Pending_Instantiations.Last
4945 and then Serious_Errors_Detected = 0
4946 loop
4947 K := Called_Pending_Instantiations.Table (J);
4948 Info := Pending_Instantiations.Table (K);
4949 Instantiate_Body (Info);
38cbfe40 4950
4b96d386
EB
4951 J := J + 1;
4952 end loop;
38cbfe40 4953
4b96d386
EB
4954 else
4955 while J <= Pending_Instantiations.Last
4956 and then Serious_Errors_Detected = 0
4957 loop
4958 Info := Pending_Instantiations.Table (J);
4959 Instantiate_Body (Info);
38cbfe40 4960
4b96d386
EB
4961 J := J + 1;
4962 end loop;
4963 end if;
38cbfe40
RK
4964
4965 -- Reset the table of instantiations. Additional instantiations
4966 -- may be added through inlining, when additional bodies are
4967 -- analyzed.
4968
4b96d386
EB
4969 if Back_End_Inlining then
4970 Called_Pending_Instantiations.Init;
4971 else
4972 Pending_Instantiations.Init;
4973 end if;
38cbfe40 4974
1f6b0d91 4975 -- Expand the cleanup actions of scopes that contain instantiations
38cbfe40 4976
1f6b0d91 4977 if Expander_Active then
38cbfe40 4978 Cleanup_Scopes;
38cbfe40
RK
4979 end if;
4980
4981 Pop_Scope;
4982 end if;
4983 end Instantiate_Bodies;
4984
4985 ---------------
4986 -- Is_Nested --
4987 ---------------
4988
4989 function Is_Nested (E : Entity_Id) return Boolean is
5132708f 4990 Scop : Entity_Id;
38cbfe40
RK
4991
4992 begin
5132708f 4993 Scop := Scope (E);
38cbfe40 4994 while Scop /= Standard_Standard loop
4b96d386 4995 if Is_Subprogram (Scop) then
38cbfe40
RK
4996 return True;
4997
4998 elsif Ekind (Scop) = E_Task_Type
4999 or else Ekind (Scop) = E_Entry
0b7f0f0e
AC
5000 or else Ekind (Scop) = E_Entry_Family
5001 then
38cbfe40
RK
5002 return True;
5003 end if;
5004
5005 Scop := Scope (Scop);
5006 end loop;
5007
5008 return False;
5009 end Is_Nested;
5010
16b10ccc
AC
5011 ------------------------
5012 -- List_Inlining_Info --
5013 ------------------------
5014
5015 procedure List_Inlining_Info is
5016 Elmt : Elmt_Id;
5017 Nod : Node_Id;
5018 Count : Nat;
5019
5020 begin
5021 if not Debug_Flag_Dot_J then
5022 return;
5023 end if;
5024
5025 -- Generate listing of calls inlined by the frontend
5026
5027 if Present (Inlined_Calls) then
5028 Count := 0;
5029 Elmt := First_Elmt (Inlined_Calls);
5030 while Present (Elmt) loop
5031 Nod := Node (Elmt);
5032
4a6db9fd 5033 if not In_Internal_Unit (Nod) then
16b10ccc
AC
5034 Count := Count + 1;
5035
5036 if Count = 1 then
1725676d 5037 Write_Str ("List of calls inlined by the frontend");
16b10ccc
AC
5038 Write_Eol;
5039 end if;
5040
5041 Write_Str (" ");
5042 Write_Int (Count);
5043 Write_Str (":");
5044 Write_Location (Sloc (Nod));
5045 Write_Str (":");
5046 Output.Write_Eol;
5047 end if;
5048
5049 Next_Elmt (Elmt);
5050 end loop;
5051 end if;
5052
5053 -- Generate listing of calls passed to the backend
5054
5055 if Present (Backend_Calls) then
5056 Count := 0;
5057
5058 Elmt := First_Elmt (Backend_Calls);
5059 while Present (Elmt) loop
5060 Nod := Node (Elmt);
5061
4a6db9fd 5062 if not In_Internal_Unit (Nod) then
16b10ccc
AC
5063 Count := Count + 1;
5064
5065 if Count = 1 then
1725676d 5066 Write_Str ("List of inlined calls passed to the backend");
16b10ccc
AC
5067 Write_Eol;
5068 end if;
5069
5070 Write_Str (" ");
5071 Write_Int (Count);
5072 Write_Str (":");
5073 Write_Location (Sloc (Nod));
5074 Output.Write_Eol;
5075 end if;
5076
4b96d386
EB
5077 Next_Elmt (Elmt);
5078 end loop;
5079 end if;
5080
5081 -- Generate listing of instances inlined for the backend
5082
5083 if Present (Backend_Instances) then
5084 Count := 0;
5085
5086 Elmt := First_Elmt (Backend_Instances);
5087 while Present (Elmt) loop
5088 Nod := Node (Elmt);
5089
5090 if not In_Internal_Unit (Nod) then
5091 Count := Count + 1;
5092
5093 if Count = 1 then
5094 Write_Str ("List of instances inlined for the backend");
5095 Write_Eol;
5096 end if;
5097
5098 Write_Str (" ");
5099 Write_Int (Count);
5100 Write_Str (":");
5101 Write_Location (Sloc (Nod));
5102 Output.Write_Eol;
5103 end if;
5104
16b10ccc
AC
5105 Next_Elmt (Elmt);
5106 end loop;
5107 end if;
5108
5109 -- Generate listing of subprograms passed to the backend
5110
62a64085 5111 if Present (Backend_Inlined_Subps) and then Back_End_Inlining then
16b10ccc
AC
5112 Count := 0;
5113
5114 Elmt := First_Elmt (Backend_Inlined_Subps);
5115 while Present (Elmt) loop
5116 Nod := Node (Elmt);
5117
4a6db9fd
EB
5118 if not In_Internal_Unit (Nod) then
5119 Count := Count + 1;
16b10ccc 5120
4a6db9fd
EB
5121 if Count = 1 then
5122 Write_Str
5123 ("List of inlined subprograms passed to the backend");
5124 Write_Eol;
5125 end if;
16b10ccc 5126
4a6db9fd
EB
5127 Write_Str (" ");
5128 Write_Int (Count);
5129 Write_Str (":");
5130 Write_Name (Chars (Nod));
5131 Write_Str (" (");
5132 Write_Location (Sloc (Nod));
5133 Write_Str (")");
5134 Output.Write_Eol;
5135 end if;
16b10ccc
AC
5136
5137 Next_Elmt (Elmt);
5138 end loop;
5139 end if;
5140
1725676d 5141 -- Generate listing of subprograms that cannot be inlined by the backend
16b10ccc 5142
62a64085 5143 if Present (Backend_Not_Inlined_Subps) and then Back_End_Inlining then
16b10ccc
AC
5144 Count := 0;
5145
5146 Elmt := First_Elmt (Backend_Not_Inlined_Subps);
5147 while Present (Elmt) loop
5148 Nod := Node (Elmt);
5149
4a6db9fd
EB
5150 if not In_Internal_Unit (Nod) then
5151 Count := Count + 1;
16b10ccc 5152
4a6db9fd
EB
5153 if Count = 1 then
5154 Write_Str
5155 ("List of subprograms that cannot be inlined by backend");
5156 Write_Eol;
5157 end if;
16b10ccc 5158
4a6db9fd
EB
5159 Write_Str (" ");
5160 Write_Int (Count);
5161 Write_Str (":");
5162 Write_Name (Chars (Nod));
5163 Write_Str (" (");
5164 Write_Location (Sloc (Nod));
5165 Write_Str (")");
5166 Output.Write_Eol;
5167 end if;
16b10ccc
AC
5168
5169 Next_Elmt (Elmt);
5170 end loop;
5171 end if;
5172 end List_Inlining_Info;
5173
38cbfe40
RK
5174 ----------
5175 -- Lock --
5176 ----------
5177
5178 procedure Lock is
5179 begin
38cbfe40 5180 Pending_Instantiations.Release;
de33eb38 5181 Pending_Instantiations.Locked := True;
92b635e5
EB
5182 Called_Pending_Instantiations.Release;
5183 Called_Pending_Instantiations.Locked := True;
38cbfe40 5184 Inlined_Bodies.Release;
de33eb38 5185 Inlined_Bodies.Locked := True;
38cbfe40 5186 Successors.Release;
de33eb38 5187 Successors.Locked := True;
38cbfe40 5188 Inlined.Release;
de33eb38 5189 Inlined.Locked := True;
38cbfe40
RK
5190 end Lock;
5191
697b781a
AC
5192 --------------------------------
5193 -- Remove_Aspects_And_Pragmas --
5194 --------------------------------
16b10ccc 5195
697b781a
AC
5196 procedure Remove_Aspects_And_Pragmas (Body_Decl : Node_Id) is
5197 procedure Remove_Items (List : List_Id);
5198 -- Remove all useless aspects/pragmas from a particular list
16b10ccc 5199
697b781a
AC
5200 ------------------
5201 -- Remove_Items --
5202 ------------------
16b10ccc 5203
697b781a
AC
5204 procedure Remove_Items (List : List_Id) is
5205 Item : Node_Id;
5206 Item_Id : Node_Id;
5207 Next_Item : Node_Id;
5208
5209 begin
5210 -- Traverse the list looking for an aspect specification or a pragma
5211
5212 Item := First (List);
5213 while Present (Item) loop
5214 Next_Item := Next (Item);
5215
5216 if Nkind (Item) = N_Aspect_Specification then
5217 Item_Id := Identifier (Item);
5218 elsif Nkind (Item) = N_Pragma then
5219 Item_Id := Pragma_Identifier (Item);
5220 else
5221 Item_Id := Empty;
5222 end if;
5223
5224 if Present (Item_Id)
dcc60142
PT
5225 and then Chars (Item_Id) in Name_Always_Terminates
5226 | Name_Contract_Cases
4a08c95c
AC
5227 | Name_Global
5228 | Name_Depends
61285c48 5229 | Name_Exceptional_Cases
f49b098e 5230 | Name_Exit_Cases
4a08c95c
AC
5231 | Name_Postcondition
5232 | Name_Precondition
899c0d2d 5233 | Name_Program_Exit
4a08c95c
AC
5234 | Name_Refined_Global
5235 | Name_Refined_Depends
5236 | Name_Refined_Post
afa1ffd4 5237 | Name_Subprogram_Variant
4a08c95c
AC
5238 | Name_Test_Case
5239 | Name_Unmodified
5240 | Name_Unreferenced
5241 | Name_Unused
697b781a
AC
5242 then
5243 Remove (Item);
5244 end if;
16b10ccc 5245
697b781a
AC
5246 Item := Next_Item;
5247 end loop;
5248 end Remove_Items;
5249
5250 -- Start of processing for Remove_Aspects_And_Pragmas
5251
5252 begin
5253 Remove_Items (Aspect_Specifications (Body_Decl));
5254 Remove_Items (Declarations (Body_Decl));
da9683f4 5255
fae8eb5b 5256 -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
da9683f4
AC
5257 -- in the body of the subprogram.
5258
5259 Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
697b781a 5260 end Remove_Aspects_And_Pragmas;
16b10ccc 5261
eefd2467
AC
5262 --------------------------
5263 -- Remove_Dead_Instance --
5264 --------------------------
5265
5266 procedure Remove_Dead_Instance (N : Node_Id) is
eefd2467 5267 begin
6feab95c 5268 for J in 0 .. Pending_Instantiations.Last loop
eefd2467
AC
5269 if Pending_Instantiations.Table (J).Inst_Node = N then
5270 Pending_Instantiations.Table (J).Inst_Node := Empty;
5271 return;
5272 end if;
eefd2467
AC
5273 end loop;
5274 end Remove_Dead_Instance;
5275
bbab2db3
GD
5276 -------------------------------------------
5277 -- Reset_Actual_Mapping_For_Inlined_Call --
5278 -------------------------------------------
5279
5280 procedure Reset_Actual_Mapping_For_Inlined_Call (Subp : Entity_Id) is
5281 F : Entity_Id := First_Formal (Subp);
5282
5283 begin
5284 while Present (F) loop
5285 Set_Renamed_Object (F, Empty);
5286 Next_Formal (F);
5287 end loop;
5288 end Reset_Actual_Mapping_For_Inlined_Call;
5289
38cbfe40 5290end Inline;