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