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