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