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