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-2013, 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 Atree; use Atree; 27with Einfo; use Einfo; 28with Elists; use Elists; 29with Errout; use Errout; 30with Exp_Ch7; use Exp_Ch7; 31with Exp_Tss; use Exp_Tss; 32with Fname; use Fname; 33with Fname.UF; use Fname.UF; 34with Lib; use Lib; 35with Namet; use Namet; 36with Nlists; use Nlists; 37with Sem_Aux; use Sem_Aux; 38with Sem_Ch8; use Sem_Ch8; 39with Sem_Ch10; use Sem_Ch10; 40with Sem_Ch12; use Sem_Ch12; 41with Sem_Util; use Sem_Util; 42with Sinfo; use Sinfo; 43with Snames; use Snames; 44with Stand; use Stand; 45with Uname; use Uname; 46 47package body Inline is 48 49 -------------------- 50 -- Inlined Bodies -- 51 -------------------- 52 53 -- Inlined functions are actually placed in line by the backend if the 54 -- corresponding bodies are available (i.e. compiled). Whenever we find 55 -- a call to an inlined subprogram, we add the name of the enclosing 56 -- compilation unit to a worklist. After all compilation, and after 57 -- expansion of generic bodies, we traverse the list of pending bodies 58 -- and compile them as well. 59 60 package Inlined_Bodies is new Table.Table ( 61 Table_Component_Type => Entity_Id, 62 Table_Index_Type => Int, 63 Table_Low_Bound => 0, 64 Table_Initial => Alloc.Inlined_Bodies_Initial, 65 Table_Increment => Alloc.Inlined_Bodies_Increment, 66 Table_Name => "Inlined_Bodies"); 67 68 ----------------------- 69 -- Inline Processing -- 70 ----------------------- 71 72 -- For each call to an inlined subprogram, we make entries in a table 73 -- that stores caller and callee, and indicates the call direction from 74 -- one to the other. We also record the compilation unit that contains 75 -- the callee. After analyzing the bodies of all such compilation units, 76 -- we compute the transitive closure of inlined subprograms called from 77 -- the main compilation unit and make it available to the code generator 78 -- in no particular order, thus allowing cycles in the call graph. 79 80 Last_Inlined : Entity_Id := Empty; 81 82 -- For each entry in the table we keep a list of successors in topological 83 -- order, i.e. callers of the current subprogram. 84 85 type Subp_Index is new Nat; 86 No_Subp : constant Subp_Index := 0; 87 88 -- The subprogram entities are hashed into the Inlined table 89 90 Num_Hash_Headers : constant := 512; 91 92 Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1) 93 of Subp_Index; 94 95 type Succ_Index is new Nat; 96 No_Succ : constant Succ_Index := 0; 97 98 type Succ_Info is record 99 Subp : Subp_Index; 100 Next : Succ_Index; 101 end record; 102 103 -- The following table stores list elements for the successor lists. 104 -- These lists cannot be chained directly through entries in the Inlined 105 -- table, because a given subprogram can appear in several such lists. 106 107 package Successors is new Table.Table ( 108 Table_Component_Type => Succ_Info, 109 Table_Index_Type => Succ_Index, 110 Table_Low_Bound => 1, 111 Table_Initial => Alloc.Successors_Initial, 112 Table_Increment => Alloc.Successors_Increment, 113 Table_Name => "Successors"); 114 115 type Subp_Info is record 116 Name : Entity_Id := Empty; 117 Next : Subp_Index := No_Subp; 118 First_Succ : Succ_Index := No_Succ; 119 Listed : Boolean := False; 120 Main_Call : Boolean := False; 121 Processed : Boolean := False; 122 end record; 123 124 package Inlined is new Table.Table ( 125 Table_Component_Type => Subp_Info, 126 Table_Index_Type => Subp_Index, 127 Table_Low_Bound => 1, 128 Table_Initial => Alloc.Inlined_Initial, 129 Table_Increment => Alloc.Inlined_Increment, 130 Table_Name => "Inlined"); 131 132 ----------------------- 133 -- Local Subprograms -- 134 ----------------------- 135 136 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id; 137 pragma Inline (Get_Code_Unit_Entity); 138 -- Return the entity node for the unit containing E. Always return 139 -- the spec for a package. 140 141 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean; 142 -- Return True if E is in the main unit or its spec or in a subunit 143 144 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty); 145 -- Make two entries in Inlined table, for an inlined subprogram being 146 -- called, and for the inlined subprogram that contains the call. If 147 -- the call is in the main compilation unit, Caller is Empty. 148 149 function Add_Subp (E : Entity_Id) return Subp_Index; 150 -- Make entry in Inlined table for subprogram E, or return table index 151 -- that already holds E. 152 153 function Has_Initialized_Type (E : Entity_Id) return Boolean; 154 -- If a candidate for inlining contains type declarations for types with 155 -- non-trivial initialization procedures, they are not worth inlining. 156 157 function Is_Nested (E : Entity_Id) return Boolean; 158 -- If the function is nested inside some other function, it will 159 -- always be compiled if that function is, so don't add it to the 160 -- inline list. We cannot compile a nested function outside the 161 -- scope of the containing function anyway. This is also the case if 162 -- the function is defined in a task body or within an entry (for 163 -- example, an initialization procedure). 164 165 procedure Add_Inlined_Subprogram (Index : Subp_Index); 166 -- Add the subprogram to the list of inlined subprogram for the unit 167 168 ------------------------------ 169 -- Deferred Cleanup Actions -- 170 ------------------------------ 171 172 -- The cleanup actions for scopes that contain instantiations is delayed 173 -- until after expansion of those instantiations, because they may 174 -- contain finalizable objects or tasks that affect the cleanup code. 175 -- A scope that contains instantiations only needs to be finalized once, 176 -- even if it contains more than one instance. We keep a list of scopes 177 -- that must still be finalized, and call cleanup_actions after all the 178 -- instantiations have been completed. 179 180 To_Clean : Elist_Id; 181 182 procedure Add_Scope_To_Clean (Inst : Entity_Id); 183 -- Build set of scopes on which cleanup actions must be performed 184 185 procedure Cleanup_Scopes; 186 -- Complete cleanup actions on scopes that need it 187 188 -------------- 189 -- Add_Call -- 190 -------------- 191 192 procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is 193 P1 : constant Subp_Index := Add_Subp (Called); 194 P2 : Subp_Index; 195 J : Succ_Index; 196 197 begin 198 if Present (Caller) then 199 P2 := Add_Subp (Caller); 200 201 -- Add P1 to the list of successors of P2, if not already there. 202 -- Note that P2 may contain more than one call to P1, and only 203 -- one needs to be recorded. 204 205 J := Inlined.Table (P2).First_Succ; 206 while J /= No_Succ loop 207 if Successors.Table (J).Subp = P1 then 208 return; 209 end if; 210 211 J := Successors.Table (J).Next; 212 end loop; 213 214 -- On exit, make a successor entry for P1 215 216 Successors.Increment_Last; 217 Successors.Table (Successors.Last).Subp := P1; 218 Successors.Table (Successors.Last).Next := 219 Inlined.Table (P2).First_Succ; 220 Inlined.Table (P2).First_Succ := Successors.Last; 221 else 222 Inlined.Table (P1).Main_Call := True; 223 end if; 224 end Add_Call; 225 226 ---------------------- 227 -- Add_Inlined_Body -- 228 ---------------------- 229 230 procedure Add_Inlined_Body (E : Entity_Id) is 231 232 type Inline_Level_Type is (Dont_Inline, Inline_Call, Inline_Package); 233 -- Level of inlining for the call: Dont_Inline means no inlining, 234 -- Inline_Call means that only the call is considered for inlining, 235 -- Inline_Package means that the call is considered for inlining and 236 -- its package compiled and scanned for more inlining opportunities. 237 238 function Must_Inline return Inline_Level_Type; 239 -- Inlining is only done if the call statement N is in the main unit, 240 -- or within the body of another inlined subprogram. 241 242 ----------------- 243 -- Must_Inline -- 244 ----------------- 245 246 function Must_Inline return Inline_Level_Type is 247 Scop : Entity_Id; 248 Comp : Node_Id; 249 250 begin 251 -- Check if call is in main unit 252 253 Scop := Current_Scope; 254 255 -- Do not try to inline if scope is standard. This could happen, for 256 -- example, for a call to Add_Global_Declaration, and it causes 257 -- trouble to try to inline at this level. 258 259 if Scop = Standard_Standard then 260 return Dont_Inline; 261 end if; 262 263 -- Otherwise lookup scope stack to outer scope 264 265 while Scope (Scop) /= Standard_Standard 266 and then not Is_Child_Unit (Scop) 267 loop 268 Scop := Scope (Scop); 269 end loop; 270 271 Comp := Parent (Scop); 272 while Nkind (Comp) /= N_Compilation_Unit loop 273 Comp := Parent (Comp); 274 end loop; 275 276 -- If the call is in the main unit, inline the call and compile the 277 -- package of the subprogram to find more calls to be inlined. 278 279 if Comp = Cunit (Main_Unit) 280 or else Comp = Library_Unit (Cunit (Main_Unit)) 281 then 282 Add_Call (E); 283 return Inline_Package; 284 end if; 285 286 -- The call is not in the main unit. See if it is in some inlined 287 -- subprogram. If so, inline the call and, if the inlining level is 288 -- set to 1, stop there; otherwise also compile the package as above. 289 290 Scop := Current_Scope; 291 while Scope (Scop) /= Standard_Standard 292 and then not Is_Child_Unit (Scop) 293 loop 294 if Is_Overloadable (Scop) 295 and then Is_Inlined (Scop) 296 then 297 Add_Call (E, Scop); 298 299 if Inline_Level = 1 then 300 return Inline_Call; 301 else 302 return Inline_Package; 303 end if; 304 end if; 305 306 Scop := Scope (Scop); 307 end loop; 308 309 return Dont_Inline; 310 end Must_Inline; 311 312 Level : Inline_Level_Type; 313 314 -- Start of processing for Add_Inlined_Body 315 316 begin 317 -- Find unit containing E, and add to list of inlined bodies if needed. 318 -- If the body is already present, no need to load any other unit. This 319 -- is the case for an initialization procedure, which appears in the 320 -- package declaration that contains the type. It is also the case if 321 -- the body has already been analyzed. Finally, if the unit enclosing 322 -- E is an instance, the instance body will be analyzed in any case, 323 -- and there is no need to add the enclosing unit (whose body might not 324 -- be available). 325 326 -- Library-level functions must be handled specially, because there is 327 -- no enclosing package to retrieve. In this case, it is the body of 328 -- the function that will have to be loaded. 329 330 if Is_Abstract_Subprogram (E) 331 or else Is_Nested (E) 332 or else Convention (E) = Convention_Protected 333 then 334 return; 335 end if; 336 337 Level := Must_Inline; 338 if Level /= Dont_Inline then 339 declare 340 Pack : constant Entity_Id := Get_Code_Unit_Entity (E); 341 342 begin 343 if Pack = E then 344 345 -- Library-level inlined function. Add function itself to 346 -- list of needed units. 347 348 Set_Is_Called (E); 349 Inlined_Bodies.Increment_Last; 350 Inlined_Bodies.Table (Inlined_Bodies.Last) := E; 351 352 elsif Ekind (Pack) = E_Package then 353 Set_Is_Called (E); 354 355 if Is_Generic_Instance (Pack) then 356 null; 357 358 -- Do not inline the package if the subprogram is an init proc 359 -- or other internally generated subprogram, because in that 360 -- case the subprogram body appears in the same unit that 361 -- declares the type, and that body is visible to the back end. 362 -- Do not inline it either if it is in the main unit. 363 364 elsif Level = Inline_Package 365 and then not Is_Inlined (Pack) 366 and then Comes_From_Source (E) 367 and then not In_Main_Unit_Or_Subunit (Pack) 368 then 369 Set_Is_Inlined (Pack); 370 Inlined_Bodies.Increment_Last; 371 Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack; 372 end if; 373 end if; 374 end; 375 end if; 376 end Add_Inlined_Body; 377 378 ---------------------------- 379 -- Add_Inlined_Subprogram -- 380 ---------------------------- 381 382 procedure Add_Inlined_Subprogram (Index : Subp_Index) is 383 E : constant Entity_Id := Inlined.Table (Index).Name; 384 Pack : constant Entity_Id := Get_Code_Unit_Entity (E); 385 386 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean; 387 -- There are various conditions under which back-end inlining cannot 388 -- be done reliably: 389 -- 390 -- a) If a body has handlers, it must not be inlined, because this 391 -- may violate program semantics, and because in zero-cost exception 392 -- mode it will lead to undefined symbols at link time. 393 -- 394 -- b) If a body contains inlined function instances, it cannot be 395 -- inlined under ZCX because the numeric suffix generated by gigi 396 -- will be different in the body and the place of the inlined call. 397 -- 398 -- This procedure must be carefully coordinated with the back end. 399 400 ---------------------------- 401 -- Back_End_Cannot_Inline -- 402 ---------------------------- 403 404 function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is 405 Decl : constant Node_Id := Unit_Declaration_Node (Subp); 406 Body_Ent : Entity_Id; 407 Ent : Entity_Id; 408 409 begin 410 if Nkind (Decl) = N_Subprogram_Declaration 411 and then Present (Corresponding_Body (Decl)) 412 then 413 Body_Ent := Corresponding_Body (Decl); 414 else 415 return False; 416 end if; 417 418 -- If subprogram is marked Inline_Always, inlining is mandatory 419 420 if Has_Pragma_Inline_Always (Subp) then 421 return False; 422 end if; 423 424 if Present 425 (Exception_Handlers 426 (Handled_Statement_Sequence 427 (Unit_Declaration_Node (Corresponding_Body (Decl))))) 428 then 429 return True; 430 end if; 431 432 Ent := First_Entity (Body_Ent); 433 while Present (Ent) loop 434 if Is_Subprogram (Ent) 435 and then Is_Generic_Instance (Ent) 436 then 437 return True; 438 end if; 439 440 Next_Entity (Ent); 441 end loop; 442 443 return False; 444 end Back_End_Cannot_Inline; 445 446 -- Start of processing for Add_Inlined_Subprogram 447 448 begin 449 -- If the subprogram is to be inlined, and if its unit is known to be 450 -- inlined or is an instance whose body will be analyzed anyway or the 451 -- subprogram has been generated by the compiler, and if it is declared 452 -- at the library level not in the main unit, and if it can be inlined 453 -- by the back-end, then insert it in the list of inlined subprograms. 454 455 if Is_Inlined (E) 456 and then (Is_Inlined (Pack) 457 or else Is_Generic_Instance (Pack) 458 or else Is_Internal (E)) 459 and then not In_Main_Unit_Or_Subunit (E) 460 and then not Is_Nested (E) 461 and then not Has_Initialized_Type (E) 462 then 463 if Back_End_Cannot_Inline (E) then 464 Set_Is_Inlined (E, False); 465 466 else 467 if No (Last_Inlined) then 468 Set_First_Inlined_Subprogram (Cunit (Main_Unit), E); 469 else 470 Set_Next_Inlined_Subprogram (Last_Inlined, E); 471 end if; 472 473 Last_Inlined := E; 474 end if; 475 end if; 476 477 Inlined.Table (Index).Listed := True; 478 end Add_Inlined_Subprogram; 479 480 ------------------------ 481 -- Add_Scope_To_Clean -- 482 ------------------------ 483 484 procedure Add_Scope_To_Clean (Inst : Entity_Id) is 485 Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst); 486 Elmt : Elmt_Id; 487 488 begin 489 -- If the instance appears in a library-level package declaration, 490 -- all finalization is global, and nothing needs doing here. 491 492 if Scop = Standard_Standard then 493 return; 494 end if; 495 496 -- If the instance is within a generic unit, no finalization code 497 -- can be generated. Note that at this point all bodies have been 498 -- analyzed, and the scope stack itself is not present, and the flag 499 -- Inside_A_Generic is not set. 500 501 declare 502 S : Entity_Id; 503 504 begin 505 S := Scope (Inst); 506 while Present (S) and then S /= Standard_Standard loop 507 if Is_Generic_Unit (S) then 508 return; 509 end if; 510 511 S := Scope (S); 512 end loop; 513 end; 514 515 Elmt := First_Elmt (To_Clean); 516 while Present (Elmt) loop 517 if Node (Elmt) = Scop then 518 return; 519 end if; 520 521 Elmt := Next_Elmt (Elmt); 522 end loop; 523 524 Append_Elmt (Scop, To_Clean); 525 end Add_Scope_To_Clean; 526 527 -------------- 528 -- Add_Subp -- 529 -------------- 530 531 function Add_Subp (E : Entity_Id) return Subp_Index is 532 Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers; 533 J : Subp_Index; 534 535 procedure New_Entry; 536 -- Initialize entry in Inlined table 537 538 procedure New_Entry is 539 begin 540 Inlined.Increment_Last; 541 Inlined.Table (Inlined.Last).Name := E; 542 Inlined.Table (Inlined.Last).Next := No_Subp; 543 Inlined.Table (Inlined.Last).First_Succ := No_Succ; 544 Inlined.Table (Inlined.Last).Listed := False; 545 Inlined.Table (Inlined.Last).Main_Call := False; 546 Inlined.Table (Inlined.Last).Processed := False; 547 end New_Entry; 548 549 -- Start of processing for Add_Subp 550 551 begin 552 if Hash_Headers (Index) = No_Subp then 553 New_Entry; 554 Hash_Headers (Index) := Inlined.Last; 555 return Inlined.Last; 556 557 else 558 J := Hash_Headers (Index); 559 while J /= No_Subp loop 560 if Inlined.Table (J).Name = E then 561 return J; 562 else 563 Index := J; 564 J := Inlined.Table (J).Next; 565 end if; 566 end loop; 567 568 -- On exit, subprogram was not found. Enter in table. Index is 569 -- the current last entry on the hash chain. 570 571 New_Entry; 572 Inlined.Table (Index).Next := Inlined.Last; 573 return Inlined.Last; 574 end if; 575 end Add_Subp; 576 577 ---------------------------- 578 -- Analyze_Inlined_Bodies -- 579 ---------------------------- 580 581 procedure Analyze_Inlined_Bodies is 582 Comp_Unit : Node_Id; 583 J : Int; 584 Pack : Entity_Id; 585 Subp : Subp_Index; 586 S : Succ_Index; 587 588 type Pending_Index is new Nat; 589 590 package Pending_Inlined is new Table.Table ( 591 Table_Component_Type => Subp_Index, 592 Table_Index_Type => Pending_Index, 593 Table_Low_Bound => 1, 594 Table_Initial => Alloc.Inlined_Initial, 595 Table_Increment => Alloc.Inlined_Increment, 596 Table_Name => "Pending_Inlined"); 597 -- The workpile used to compute the transitive closure 598 599 function Is_Ancestor_Of_Main 600 (U_Name : Entity_Id; 601 Nam : Node_Id) return Boolean; 602 -- Determine whether the unit whose body is loaded is an ancestor of 603 -- the main unit, and has a with_clause on it. The body is not 604 -- analyzed yet, so the check is purely lexical: the name of the with 605 -- clause is a selected component, and names of ancestors must match. 606 607 ------------------------- 608 -- Is_Ancestor_Of_Main -- 609 ------------------------- 610 611 function Is_Ancestor_Of_Main 612 (U_Name : Entity_Id; 613 Nam : Node_Id) return Boolean 614 is 615 Pref : Node_Id; 616 617 begin 618 if Nkind (Nam) /= N_Selected_Component then 619 return False; 620 621 else 622 if Chars (Selector_Name (Nam)) /= 623 Chars (Cunit_Entity (Main_Unit)) 624 then 625 return False; 626 end if; 627 628 Pref := Prefix (Nam); 629 if Nkind (Pref) = N_Identifier then 630 631 -- Par is an ancestor of Par.Child. 632 633 return Chars (Pref) = Chars (U_Name); 634 635 elsif Nkind (Pref) = N_Selected_Component 636 and then Chars (Selector_Name (Pref)) = Chars (U_Name) 637 then 638 -- Par.Child is an ancestor of Par.Child.Grand. 639 640 return True; -- should check that ancestor match 641 642 else 643 -- A is an ancestor of A.B.C if it is an ancestor of A.B 644 645 return Is_Ancestor_Of_Main (U_Name, Pref); 646 end if; 647 end if; 648 end Is_Ancestor_Of_Main; 649 650 -- Start of processing for Analyze_Inlined_Bodies 651 652 begin 653 if Serious_Errors_Detected = 0 then 654 Push_Scope (Standard_Standard); 655 656 J := 0; 657 while J <= Inlined_Bodies.Last 658 and then Serious_Errors_Detected = 0 659 loop 660 Pack := Inlined_Bodies.Table (J); 661 while Present (Pack) 662 and then Scope (Pack) /= Standard_Standard 663 and then not Is_Child_Unit (Pack) 664 loop 665 Pack := Scope (Pack); 666 end loop; 667 668 Comp_Unit := Parent (Pack); 669 while Present (Comp_Unit) 670 and then Nkind (Comp_Unit) /= N_Compilation_Unit 671 loop 672 Comp_Unit := Parent (Comp_Unit); 673 end loop; 674 675 -- Load the body, unless it is the main unit, or is an instance 676 -- whose body has already been analyzed. 677 678 if Present (Comp_Unit) 679 and then Comp_Unit /= Cunit (Main_Unit) 680 and then Body_Required (Comp_Unit) 681 and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration 682 or else No (Corresponding_Body (Unit (Comp_Unit)))) 683 then 684 declare 685 Bname : constant Unit_Name_Type := 686 Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))); 687 688 OK : Boolean; 689 690 begin 691 if not Is_Loaded (Bname) then 692 Style_Check := False; 693 Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False); 694 695 if not OK then 696 697 -- Warn that a body was not available for inlining 698 -- by the back-end. 699 700 Error_Msg_Unit_1 := Bname; 701 Error_Msg_N 702 ("one or more inlined subprograms accessed in $!??", 703 Comp_Unit); 704 Error_Msg_File_1 := 705 Get_File_Name (Bname, Subunit => False); 706 Error_Msg_N ("\but file{ was not found!??", Comp_Unit); 707 708 else 709 -- If the package to be inlined is an ancestor unit of 710 -- the main unit, and it has a semantic dependence on 711 -- it, the inlining cannot take place to prevent an 712 -- elaboration circularity. The desired body is not 713 -- analyzed yet, to prevent the completion of Taft 714 -- amendment types that would lead to elaboration 715 -- circularities in gigi. 716 717 declare 718 U_Id : constant Entity_Id := 719 Defining_Entity (Unit (Comp_Unit)); 720 Body_Unit : constant Node_Id := 721 Library_Unit (Comp_Unit); 722 Item : Node_Id; 723 724 begin 725 Item := First (Context_Items (Body_Unit)); 726 while Present (Item) loop 727 if Nkind (Item) = N_With_Clause 728 and then 729 Is_Ancestor_Of_Main (U_Id, Name (Item)) 730 then 731 Set_Is_Inlined (U_Id, False); 732 exit; 733 end if; 734 735 Next (Item); 736 end loop; 737 738 -- If no suspicious with_clauses, analyze the body. 739 740 if Is_Inlined (U_Id) then 741 Semantics (Body_Unit); 742 end if; 743 end; 744 end if; 745 end if; 746 end; 747 end if; 748 749 J := J + 1; 750 end loop; 751 752 -- The analysis of required bodies may have produced additional 753 -- generic instantiations. To obtain further inlining, we perform 754 -- another round of generic body instantiations. Establishing a 755 -- fully recursive loop between inlining and generic instantiations 756 -- is unlikely to yield more than this one additional pass. 757 758 Instantiate_Bodies; 759 760 -- The list of inlined subprograms is an overestimate, because it 761 -- includes inlined functions called from functions that are compiled 762 -- as part of an inlined package, but are not themselves called. An 763 -- accurate computation of just those subprograms that are needed 764 -- requires that we perform a transitive closure over the call graph, 765 -- starting from calls in the main program. 766 767 for Index in Inlined.First .. Inlined.Last loop 768 if not Is_Called (Inlined.Table (Index).Name) then 769 770 -- This means that Add_Inlined_Body added the subprogram to the 771 -- table but wasn't able to handle its code unit. Do nothing. 772 773 Inlined.Table (Index).Processed := True; 774 775 elsif Inlined.Table (Index).Main_Call then 776 Pending_Inlined.Increment_Last; 777 Pending_Inlined.Table (Pending_Inlined.Last) := Index; 778 Inlined.Table (Index).Processed := True; 779 780 else 781 Set_Is_Called (Inlined.Table (Index).Name, False); 782 end if; 783 end loop; 784 785 -- Iterate over the workpile until it is emptied, propagating the 786 -- Is_Called flag to the successors of the processed subprogram. 787 788 while Pending_Inlined.Last >= Pending_Inlined.First loop 789 Subp := Pending_Inlined.Table (Pending_Inlined.Last); 790 Pending_Inlined.Decrement_Last; 791 792 S := Inlined.Table (Subp).First_Succ; 793 794 while S /= No_Succ loop 795 Subp := Successors.Table (S).Subp; 796 797 if not Inlined.Table (Subp).Processed then 798 Set_Is_Called (Inlined.Table (Subp).Name); 799 Pending_Inlined.Increment_Last; 800 Pending_Inlined.Table (Pending_Inlined.Last) := Subp; 801 Inlined.Table (Subp).Processed := True; 802 end if; 803 804 S := Successors.Table (S).Next; 805 end loop; 806 end loop; 807 808 -- Finally add the called subprograms to the list of inlined 809 -- subprograms for the unit. 810 811 for Index in Inlined.First .. Inlined.Last loop 812 if Is_Called (Inlined.Table (Index).Name) 813 and then not Inlined.Table (Index).Listed 814 then 815 Add_Inlined_Subprogram (Index); 816 end if; 817 end loop; 818 819 Pop_Scope; 820 end if; 821 end Analyze_Inlined_Bodies; 822 823 ----------------------------- 824 -- Check_Body_For_Inlining -- 825 ----------------------------- 826 827 procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is 828 Bname : Unit_Name_Type; 829 E : Entity_Id; 830 OK : Boolean; 831 832 begin 833 if Is_Compilation_Unit (P) 834 and then not Is_Generic_Instance (P) 835 then 836 Bname := Get_Body_Name (Get_Unit_Name (Unit (N))); 837 838 E := First_Entity (P); 839 while Present (E) loop 840 if Has_Pragma_Inline_Always (E) 841 or else (Front_End_Inlining and then Has_Pragma_Inline (E)) 842 then 843 if not Is_Loaded (Bname) then 844 Load_Needed_Body (N, OK); 845 846 if OK then 847 848 -- Check we are not trying to inline a parent whose body 849 -- depends on a child, when we are compiling the body of 850 -- the child. Otherwise we have a potential elaboration 851 -- circularity with inlined subprograms and with 852 -- Taft-Amendment types. 853 854 declare 855 Comp : Node_Id; -- Body just compiled 856 Child_Spec : Entity_Id; -- Spec of main unit 857 Ent : Entity_Id; -- For iteration 858 With_Clause : Node_Id; -- Context of body. 859 860 begin 861 if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body 862 and then Present (Body_Entity (P)) 863 then 864 Child_Spec := 865 Defining_Entity 866 ((Unit (Library_Unit (Cunit (Main_Unit))))); 867 868 Comp := 869 Parent (Unit_Declaration_Node (Body_Entity (P))); 870 871 -- Check whether the context of the body just 872 -- compiled includes a child of itself, and that 873 -- child is the spec of the main compilation. 874 875 With_Clause := First (Context_Items (Comp)); 876 while Present (With_Clause) loop 877 if Nkind (With_Clause) = N_With_Clause 878 and then 879 Scope (Entity (Name (With_Clause))) = P 880 and then 881 Entity (Name (With_Clause)) = Child_Spec 882 then 883 Error_Msg_Node_2 := Child_Spec; 884 Error_Msg_NE 885 ("body of & depends on child unit&??", 886 With_Clause, P); 887 Error_Msg_N 888 ("\subprograms in body cannot be inlined??", 889 With_Clause); 890 891 -- Disable further inlining from this unit, 892 -- and keep Taft-amendment types incomplete. 893 894 Ent := First_Entity (P); 895 while Present (Ent) loop 896 if Is_Type (Ent) 897 and then Has_Completion_In_Body (Ent) 898 then 899 Set_Full_View (Ent, Empty); 900 901 elsif Is_Subprogram (Ent) then 902 Set_Is_Inlined (Ent, False); 903 end if; 904 905 Next_Entity (Ent); 906 end loop; 907 908 return; 909 end if; 910 911 Next (With_Clause); 912 end loop; 913 end if; 914 end; 915 916 elsif Ineffective_Inline_Warnings then 917 Error_Msg_Unit_1 := Bname; 918 Error_Msg_N 919 ("unable to inline subprograms defined in $??", P); 920 Error_Msg_N ("\body not found??", P); 921 return; 922 end if; 923 end if; 924 925 return; 926 end if; 927 928 Next_Entity (E); 929 end loop; 930 end if; 931 end Check_Body_For_Inlining; 932 933 -------------------- 934 -- Cleanup_Scopes -- 935 -------------------- 936 937 procedure Cleanup_Scopes is 938 Elmt : Elmt_Id; 939 Decl : Node_Id; 940 Scop : Entity_Id; 941 942 begin 943 Elmt := First_Elmt (To_Clean); 944 while Present (Elmt) loop 945 Scop := Node (Elmt); 946 947 if Ekind (Scop) = E_Entry then 948 Scop := Protected_Body_Subprogram (Scop); 949 950 elsif Is_Subprogram (Scop) 951 and then Is_Protected_Type (Scope (Scop)) 952 and then Present (Protected_Body_Subprogram (Scop)) 953 then 954 -- If a protected operation contains an instance, its 955 -- cleanup operations have been delayed, and the subprogram 956 -- has been rewritten in the expansion of the enclosing 957 -- protected body. It is the corresponding subprogram that 958 -- may require the cleanup operations, so propagate the 959 -- information that triggers cleanup activity. 960 961 Set_Uses_Sec_Stack 962 (Protected_Body_Subprogram (Scop), 963 Uses_Sec_Stack (Scop)); 964 965 Scop := Protected_Body_Subprogram (Scop); 966 end if; 967 968 if Ekind (Scop) = E_Block then 969 Decl := Parent (Block_Node (Scop)); 970 971 else 972 Decl := Unit_Declaration_Node (Scop); 973 974 if Nkind (Decl) = N_Subprogram_Declaration 975 or else Nkind (Decl) = N_Task_Type_Declaration 976 or else Nkind (Decl) = N_Subprogram_Body_Stub 977 then 978 Decl := Unit_Declaration_Node (Corresponding_Body (Decl)); 979 end if; 980 end if; 981 982 Push_Scope (Scop); 983 Expand_Cleanup_Actions (Decl); 984 End_Scope; 985 986 Elmt := Next_Elmt (Elmt); 987 end loop; 988 end Cleanup_Scopes; 989 990 -------------------------- 991 -- Get_Code_Unit_Entity -- 992 -------------------------- 993 994 function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is 995 Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E)); 996 997 begin 998 if Ekind (Unit) = E_Package_Body then 999 Unit := Spec_Entity (Unit); 1000 end if; 1001 1002 return Unit; 1003 end Get_Code_Unit_Entity; 1004 1005 -------------------------- 1006 -- Has_Initialized_Type -- 1007 -------------------------- 1008 1009 function Has_Initialized_Type (E : Entity_Id) return Boolean is 1010 E_Body : constant Node_Id := Get_Subprogram_Body (E); 1011 Decl : Node_Id; 1012 1013 begin 1014 if No (E_Body) then -- imported subprogram 1015 return False; 1016 1017 else 1018 Decl := First (Declarations (E_Body)); 1019 while Present (Decl) loop 1020 1021 if Nkind (Decl) = N_Full_Type_Declaration 1022 and then Present (Init_Proc (Defining_Identifier (Decl))) 1023 then 1024 return True; 1025 end if; 1026 1027 Next (Decl); 1028 end loop; 1029 end if; 1030 1031 return False; 1032 end Has_Initialized_Type; 1033 1034 ----------------------------- 1035 -- In_Main_Unit_Or_Subunit -- 1036 ----------------------------- 1037 1038 function In_Main_Unit_Or_Subunit (E : Entity_Id) return Boolean is 1039 Comp : Node_Id := Cunit (Get_Code_Unit (E)); 1040 1041 begin 1042 -- Check whether the subprogram or package to inline is within the main 1043 -- unit or its spec or within a subunit. In either case there are no 1044 -- additional bodies to process. If the subprogram appears in a parent 1045 -- of the current unit, the check on whether inlining is possible is 1046 -- done in Analyze_Inlined_Bodies. 1047 1048 while Nkind (Unit (Comp)) = N_Subunit loop 1049 Comp := Library_Unit (Comp); 1050 end loop; 1051 1052 return Comp = Cunit (Main_Unit) 1053 or else Comp = Library_Unit (Cunit (Main_Unit)); 1054 end In_Main_Unit_Or_Subunit; 1055 1056 ---------------- 1057 -- Initialize -- 1058 ---------------- 1059 1060 procedure Initialize is 1061 begin 1062 Pending_Descriptor.Init; 1063 Pending_Instantiations.Init; 1064 Inlined_Bodies.Init; 1065 Successors.Init; 1066 Inlined.Init; 1067 1068 for J in Hash_Headers'Range loop 1069 Hash_Headers (J) := No_Subp; 1070 end loop; 1071 end Initialize; 1072 1073 ------------------------ 1074 -- Instantiate_Bodies -- 1075 ------------------------ 1076 1077 -- Generic bodies contain all the non-local references, so an 1078 -- instantiation does not need any more context than Standard 1079 -- itself, even if the instantiation appears in an inner scope. 1080 -- Generic associations have verified that the contract model is 1081 -- satisfied, so that any error that may occur in the analysis of 1082 -- the body is an internal error. 1083 1084 procedure Instantiate_Bodies is 1085 J : Int; 1086 Info : Pending_Body_Info; 1087 1088 begin 1089 if Serious_Errors_Detected = 0 then 1090 Expander_Active := (Operating_Mode = Opt.Generate_Code); 1091 Push_Scope (Standard_Standard); 1092 To_Clean := New_Elmt_List; 1093 1094 if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then 1095 Start_Generic; 1096 end if; 1097 1098 -- A body instantiation may generate additional instantiations, so 1099 -- the following loop must scan to the end of a possibly expanding 1100 -- set (that's why we can't simply use a FOR loop here). 1101 1102 J := 0; 1103 while J <= Pending_Instantiations.Last 1104 and then Serious_Errors_Detected = 0 1105 loop 1106 Info := Pending_Instantiations.Table (J); 1107 1108 -- If the instantiation node is absent, it has been removed 1109 -- as part of unreachable code. 1110 1111 if No (Info.Inst_Node) then 1112 null; 1113 1114 elsif Nkind (Info.Act_Decl) = N_Package_Declaration then 1115 Instantiate_Package_Body (Info); 1116 Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl)); 1117 1118 else 1119 Instantiate_Subprogram_Body (Info); 1120 end if; 1121 1122 J := J + 1; 1123 end loop; 1124 1125 -- Reset the table of instantiations. Additional instantiations 1126 -- may be added through inlining, when additional bodies are 1127 -- analyzed. 1128 1129 Pending_Instantiations.Init; 1130 1131 -- We can now complete the cleanup actions of scopes that contain 1132 -- pending instantiations (skipped for generic units, since we 1133 -- never need any cleanups in generic units). 1134 -- pending instantiations. 1135 1136 if Expander_Active 1137 and then not Is_Generic_Unit (Main_Unit_Entity) 1138 then 1139 Cleanup_Scopes; 1140 elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then 1141 End_Generic; 1142 end if; 1143 1144 Pop_Scope; 1145 end if; 1146 end Instantiate_Bodies; 1147 1148 --------------- 1149 -- Is_Nested -- 1150 --------------- 1151 1152 function Is_Nested (E : Entity_Id) return Boolean is 1153 Scop : Entity_Id; 1154 1155 begin 1156 Scop := Scope (E); 1157 while Scop /= Standard_Standard loop 1158 if Ekind (Scop) in Subprogram_Kind then 1159 return True; 1160 1161 elsif Ekind (Scop) = E_Task_Type 1162 or else Ekind (Scop) = E_Entry 1163 or else Ekind (Scop) = E_Entry_Family 1164 then 1165 return True; 1166 end if; 1167 1168 Scop := Scope (Scop); 1169 end loop; 1170 1171 return False; 1172 end Is_Nested; 1173 1174 ---------- 1175 -- Lock -- 1176 ---------- 1177 1178 procedure Lock is 1179 begin 1180 Pending_Instantiations.Locked := True; 1181 Inlined_Bodies.Locked := True; 1182 Successors.Locked := True; 1183 Inlined.Locked := True; 1184 Pending_Instantiations.Release; 1185 Inlined_Bodies.Release; 1186 Successors.Release; 1187 Inlined.Release; 1188 end Lock; 1189 1190 -------------------------- 1191 -- Remove_Dead_Instance -- 1192 -------------------------- 1193 1194 procedure Remove_Dead_Instance (N : Node_Id) is 1195 J : Int; 1196 1197 begin 1198 J := 0; 1199 while J <= Pending_Instantiations.Last loop 1200 if Pending_Instantiations.Table (J).Inst_Node = N then 1201 Pending_Instantiations.Table (J).Inst_Node := Empty; 1202 return; 1203 end if; 1204 1205 J := J + 1; 1206 end loop; 1207 end Remove_Dead_Instance; 1208 1209end Inline; 1210