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