gcc/ada/inline.adb

   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-2009, 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
  26 with Atree;    use Atree;
  27 with Einfo;    use Einfo;
  28 with Elists;   use Elists;
  29 with Errout;   use Errout;
  30 with Exp_Ch7;  use Exp_Ch7;
  31 with Exp_Tss;  use Exp_Tss;
  32 with Fname;    use Fname;
  33 with Fname.UF; use Fname.UF;
  34 with Lib;      use Lib;
  35 with Namet;    use Namet;
  36 with Nlists;   use Nlists;
  37 with Opt;      use Opt;
  38 with Sem_Aux;  use Sem_Aux;
  39 with Sem_Ch8;  use Sem_Ch8;
  40 with Sem_Ch10; use Sem_Ch10;
  41 with Sem_Ch12; use Sem_Ch12;
  42 with Sem_Util; use Sem_Util;
  43 with Sinfo;    use Sinfo;
  44 with Snames;   use Snames;
  45 with Stand;    use Stand;
  46 with Uname;    use Uname;
  47
  48 package 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          while J /= No_Succ loop
 210             if Successors.Table (J).Subp = P2 then
 211                return;
 212             end if;
 213
 214             J := Successors.Table (J).Next;
 215          end loop;
 216
 217          --  On exit, make a successor entry for P2
 218
 219          Successors.Increment_Last;
 220          Successors.Table (Successors.Last).Subp := P2;
 221          Successors.Table (Successors.Last).Next :=
 222                              Inlined.Table (P1).First_Succ;
 223          Inlined.Table (P1).First_Succ := Successors.Last;
 224
 225          Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1;
 226
 227       else
 228          Inlined.Table (P1).Main_Call := True;
 229       end if;
 230    end Add_Call;
 231
 232    ----------------------
 233    -- Add_Inlined_Body --
 234    ----------------------
 235
 236    procedure Add_Inlined_Body (E : Entity_Id) is
 237       Pack : Entity_Id;
 238
 239       function Must_Inline return Boolean;
 240       --  Inlining is only done if the call statement N is in the main unit,
 241       --  or within the body of another inlined subprogram.
 242
 243       -----------------
 244       -- Must_Inline --
 245       -----------------
 246
 247       function Must_Inline return Boolean is
 248          Scop : Entity_Id;
 249          Comp : Node_Id;
 250
 251       begin
 252          --  Check if call is in main unit
 253
 254          Scop := Current_Scope;
 255
 256          --  Do not try to inline if scope is standard. This could happen, for
 257          --  example, for a call to Add_Global_Declaration, and it causes
 258          --  trouble to try to inline at this level.
 259
 260          if Scop = Standard_Standard then
 261             return False;
 262          end if;
 263
 264          --  Otherwise lookup scope stack to outer scope
 265
 266          while Scope (Scop) /= Standard_Standard
 267            and then not Is_Child_Unit (Scop)
 268          loop
 269             Scop := Scope (Scop);
 270          end loop;
 271
 272          Comp := Parent (Scop);
 273          while Nkind (Comp) /= N_Compilation_Unit loop
 274             Comp := Parent (Comp);
 275          end loop;
 276
 277          if Comp = Cunit (Main_Unit)
 278            or else Comp = Library_Unit (Cunit (Main_Unit))
 279          then
 280             Add_Call (E);
 281             return True;
 282          end if;
 283
 284          --  Call is not in main unit. See if it's in some inlined subprogram
 285
 286          Scop := Current_Scope;
 287          while Scope (Scop) /= Standard_Standard
 288            and then not Is_Child_Unit (Scop)
 289          loop
 290             if Is_Overloadable (Scop)
 291               and then Is_Inlined (Scop)
 292             then
 293                Add_Call (E, Scop);
 294                return True;
 295             end if;
 296
 297             Scop := Scope (Scop);
 298          end loop;
 299
 300          return False;
 301       end Must_Inline;
 302
 303    --  Start of processing for Add_Inlined_Body
 304
 305    begin
 306       --  Find unit containing E, and add to list of inlined bodies if needed.
 307       --  If the body is already present, no need to load any other unit. This
 308       --  is the case for an initialization procedure, which appears in the
 309       --  package declaration that contains the type. It is also the case if
 310       --  the body has already been analyzed. Finally, if the unit enclosing
 311       --  E is an instance, the instance body will be analyzed in any case,
 312       --  and there is no need to add the enclosing unit (whose body might not
 313       --  be available).
 314
 315       --  Library-level functions must be handled specially, because there is
 316       --  no enclosing package to retrieve. In this case, it is the body of
 317       --  the function that will have to be loaded.
 318
 319       if not Is_Abstract_Subprogram (E) and then not Is_Nested (E)
 320         and then Convention (E) /= Convention_Protected
 321       then
 322          Pack := Scope (E);
 323
 324          if Must_Inline
 325            and then Ekind (Pack) = E_Package
 326          then
 327             Set_Is_Called (E);
 328
 329             if Pack = Standard_Standard then
 330
 331                --  Library-level inlined function. Add function itself to
 332                --  list of needed units.
 333
 334                Inlined_Bodies.Increment_Last;
 335                Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
 336
 337             elsif Is_Generic_Instance (Pack) then
 338                null;
 339
 340             elsif not Is_Inlined (Pack)
 341               and then not Has_Completion (E)
 342               and then not Scope_In_Main_Unit (Pack)
 343             then
 344                Set_Is_Inlined (Pack);
 345                Inlined_Bodies.Increment_Last;
 346                Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
 347             end if;
 348          end if;
 349       end if;
 350    end Add_Inlined_Body;
 351
 352    ----------------------------
 353    -- Add_Inlined_Subprogram --
 354    ----------------------------
 355
 356    procedure Add_Inlined_Subprogram (Index : Subp_Index) is
 357       E    : constant Entity_Id := Inlined.Table (Index).Name;
 358       Succ : Succ_Index;
 359       Subp : Subp_Index;
 360
 361       function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
 362       --  There are various conditions under which back-end inlining cannot
 363       --  be done reliably:
 364       --
 365       --    a) If a body has handlers, it must not be inlined, because this
 366       --    may violate program semantics, and because in zero-cost exception
 367       --    mode it will lead to undefined symbols at link time.
 368       --
 369       --    b) If a body contains inlined function instances, it cannot be
 370       --    inlined under ZCX because the numeric suffix generated by gigi
 371       --    will be different in the body and the place of the inlined call.
 372       --
 373       --  If the body to be inlined contains calls to subprograms declared
 374       --  in the same body that have no previous spec, the back-end cannot
 375       --  inline either because the bodies to be inlined are processed before
 376       --  the rest of the enclosing package body, and gigi will then find
 377       --  references to entities that have not been elaborated yet.
 378       --
 379       --  This procedure must be carefully coordinated with the back end.
 380
 381       ----------------------------
 382       -- Back_End_Cannot_Inline --
 383       ----------------------------
 384
 385       function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
 386          Decl     : constant Node_Id := Unit_Declaration_Node (Subp);
 387          Body_Ent : Entity_Id;
 388          Ent      : Entity_Id;
 389          Bad_Call : Node_Id;
 390
 391          function Process (N : Node_Id) return Traverse_Result;
 392          --  Look for calls to subprograms with no previous spec, declared
 393          --  in the same enclosiong package body.
 394
 395          -------------
 396          -- Process --
 397          -------------
 398
 399          function Process (N : Node_Id) return Traverse_Result is
 400          begin
 401             if Nkind (N) = N_Procedure_Call_Statement
 402               or else Nkind (N) = N_Function_Call
 403             then
 404                if Is_Entity_Name (Name (N))
 405                  and then Comes_From_Source (Entity (Name (N)))
 406                  and then
 407                     Nkind (Unit_Declaration_Node (Entity (Name (N))))
 408                       = N_Subprogram_Body
 409                  and then In_Same_Extended_Unit (Subp, Entity (Name (N)))
 410                then
 411                   Bad_Call := N;
 412                   return Abandon;
 413                else
 414                   return OK;
 415                end if;
 416             else
 417                return OK;
 418             end if;
 419          end Process;
 420
 421          function Has_Exposed_Call is new Traverse_Func (Process);
 422
 423       --  Start of processing for Back_End_Cannot_Inline
 424
 425       begin
 426          if Nkind (Decl) = N_Subprogram_Declaration
 427            and then Present (Corresponding_Body (Decl))
 428          then
 429             Body_Ent := Corresponding_Body (Decl);
 430          else
 431             return False;
 432          end if;
 433
 434          --  If subprogram is marked Inline_Always, inlining is mandatory
 435
 436          if Has_Pragma_Inline_Always (Subp) then
 437             return False;
 438          end if;
 439
 440          if Present
 441           (Exception_Handlers
 442             (Handled_Statement_Sequence
 443               (Unit_Declaration_Node (Corresponding_Body (Decl)))))
 444          then
 445             return True;
 446          end if;
 447
 448          Ent := First_Entity (Body_Ent);
 449          while Present (Ent) loop
 450             if Is_Subprogram (Ent)
 451               and then Is_Generic_Instance (Ent)
 452             then
 453                return True;
 454             end if;
 455
 456             Next_Entity (Ent);
 457          end loop;
 458
 459          if Has_Exposed_Call
 460               (Unit_Declaration_Node (Corresponding_Body (Decl))) = Abandon
 461          then
 462             if Ineffective_Inline_Warnings then
 463                Error_Msg_N
 464                  ("?call to subprogram with no separate spec"
 465                   & " prevents inlining!!", Bad_Call);
 466             end if;
 467
 468             return True;
 469          else
 470             return False;
 471          end if;
 472       end Back_End_Cannot_Inline;
 473
 474    --  Start of processing for Add_Inlined_Subprogram
 475
 476    begin
 477       --  Insert the current subprogram in the list of inlined subprograms,
 478       --  if it can actually be inlined by the back-end.
 479
 480       if not Scope_In_Main_Unit (E)
 481         and then Is_Inlined (E)
 482         and then not Is_Nested (E)
 483         and then not Has_Initialized_Type (E)
 484       then
 485          if Back_End_Cannot_Inline (E) then
 486             Set_Is_Inlined (E, False);
 487
 488          else
 489             if No (Last_Inlined) then
 490                Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
 491             else
 492                Set_Next_Inlined_Subprogram (Last_Inlined, E);
 493             end if;
 494
 495             Last_Inlined := E;
 496          end if;
 497       end if;
 498
 499       Inlined.Table (Index).Listed := True;
 500
 501       --  Now add to the list those callers of the current subprogram that
 502       --  are themselves called. They may appear on the graph as callers
 503       --  of the current one, even if they are themselves not called, and
 504       --  there is no point in including them in the list for the backend.
 505       --  Furthermore, they might not even be public, in which case the
 506       --  back-end cannot handle them at all.
 507
 508       Succ := Inlined.Table (Index).First_Succ;
 509       while Succ /= No_Succ loop
 510          Subp := Successors.Table (Succ).Subp;
 511          Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;
 512
 513          if Inlined.Table (Subp).Count = 0
 514            and then Is_Called (Inlined.Table (Subp).Name)
 515          then
 516             Add_Inlined_Subprogram (Subp);
 517          end if;
 518
 519          Succ := Successors.Table (Succ).Next;
 520       end loop;
 521    end Add_Inlined_Subprogram;
 522
 523    ------------------------
 524    -- Add_Scope_To_Clean --
 525    ------------------------
 526
 527    procedure Add_Scope_To_Clean (Inst : Entity_Id) is
 528       Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
 529       Elmt : Elmt_Id;
 530
 531    begin
 532       --  If the instance appears in a library-level package declaration,
 533       --  all finalization is global, and nothing needs doing here.
 534
 535       if Scop = Standard_Standard then
 536          return;
 537       end if;
 538
 539       --  If the instance appears within a generic subprogram there is nothing
 540       --  to finalize either.
 541
 542       declare
 543          S : Entity_Id;
 544
 545       begin
 546          S := Scope (Inst);
 547          while Present (S) and then S /= Standard_Standard loop
 548             if Is_Generic_Subprogram (S) then
 549                return;
 550             end if;
 551
 552             S := Scope (S);
 553          end loop;
 554       end;
 555
 556       Elmt := First_Elmt (To_Clean);
 557       while Present (Elmt) loop
 558          if Node (Elmt) = Scop then
 559             return;
 560          end if;
 561
 562          Elmt := Next_Elmt (Elmt);
 563       end loop;
 564
 565       Append_Elmt (Scop, To_Clean);
 566    end Add_Scope_To_Clean;
 567
 568    --------------
 569    -- Add_Subp --
 570    --------------
 571
 572    function Add_Subp (E : Entity_Id) return Subp_Index is
 573       Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
 574       J     : Subp_Index;
 575
 576       procedure New_Entry;
 577       --  Initialize entry in Inlined table
 578
 579       procedure New_Entry is
 580       begin
 581          Inlined.Increment_Last;
 582          Inlined.Table (Inlined.Last).Name        := E;
 583          Inlined.Table (Inlined.Last).First_Succ  := No_Succ;
 584          Inlined.Table (Inlined.Last).Count       := 0;
 585          Inlined.Table (Inlined.Last).Listed      := False;
 586          Inlined.Table (Inlined.Last).Main_Call   := False;
 587          Inlined.Table (Inlined.Last).Next        := No_Subp;
 588          Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
 589       end New_Entry;
 590
 591    --  Start of processing for Add_Subp
 592
 593    begin
 594       if Hash_Headers (Index) = No_Subp then
 595          New_Entry;
 596          Hash_Headers (Index) := Inlined.Last;
 597          return Inlined.Last;
 598
 599       else
 600          J := Hash_Headers (Index);
 601          while J /= No_Subp loop
 602             if Inlined.Table (J).Name = E then
 603                return J;
 604             else
 605                Index := J;
 606                J := Inlined.Table (J).Next;
 607             end if;
 608          end loop;
 609
 610          --  On exit, subprogram was not found. Enter in table. Index is
 611          --  the current last entry on the hash chain.
 612
 613          New_Entry;
 614          Inlined.Table (Index).Next := Inlined.Last;
 615          return Inlined.Last;
 616       end if;
 617    end Add_Subp;
 618
 619    ----------------------------
 620    -- Analyze_Inlined_Bodies --
 621    ----------------------------
 622
 623    procedure Analyze_Inlined_Bodies is
 624       Comp_Unit : Node_Id;
 625       J         : Int;
 626       Pack      : Entity_Id;
 627       S         : Succ_Index;
 628
 629    begin
 630       Analyzing_Inlined_Bodies := False;
 631
 632       if Serious_Errors_Detected = 0 then
 633          Push_Scope (Standard_Standard);
 634
 635          J := 0;
 636          while J <= Inlined_Bodies.Last
 637            and then Serious_Errors_Detected = 0
 638          loop
 639             Pack := Inlined_Bodies.Table (J);
 640             while Present (Pack)
 641               and then Scope (Pack) /= Standard_Standard
 642               and then not Is_Child_Unit (Pack)
 643             loop
 644                Pack := Scope (Pack);
 645             end loop;
 646
 647             Comp_Unit := Parent (Pack);
 648             while Present (Comp_Unit)
 649               and then Nkind (Comp_Unit) /= N_Compilation_Unit
 650             loop
 651                Comp_Unit := Parent (Comp_Unit);
 652             end loop;
 653
 654             --  Load the body, unless it the main unit, or is an instance
 655             --  whose body has already been analyzed.
 656
 657             if Present (Comp_Unit)
 658               and then Comp_Unit /= Cunit (Main_Unit)
 659               and then Body_Required (Comp_Unit)
 660               and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
 661                          or else No (Corresponding_Body (Unit (Comp_Unit))))
 662             then
 663                declare
 664                   Bname : constant Unit_Name_Type :=
 665                             Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
 666
 667                   OK : Boolean;
 668
 669                begin
 670                   if not Is_Loaded (Bname) then
 671                      Load_Needed_Body (Comp_Unit, OK);
 672
 673                      if not OK then
 674
 675                         --  Warn that a body was not available for inlining
 676                         --  by the back-end.
 677
 678                         Error_Msg_Unit_1 := Bname;
 679                         Error_Msg_N
 680                           ("one or more inlined subprograms accessed in $!?",
 681                            Comp_Unit);
 682                         Error_Msg_File_1 :=
 683                           Get_File_Name (Bname, Subunit => False);
 684                         Error_Msg_N ("\but file{ was not found!?", Comp_Unit);
 685                      end if;
 686                   end if;
 687                end;
 688             end if;
 689
 690             J := J + 1;
 691          end loop;
 692
 693          --  The analysis of required bodies may have produced additional
 694          --  generic instantiations. To obtain further inlining, we perform
 695          --  another round of generic body instantiations. Establishing a
 696          --  fully recursive loop between inlining and generic instantiations
 697          --  is unlikely to yield more than this one additional pass.
 698
 699          Instantiate_Bodies;
 700
 701          --  The list of inlined subprograms is an overestimate, because
 702          --  it includes inlined functions called from functions that are
 703          --  compiled as part of an inlined package, but are not themselves
 704          --  called. An accurate computation of just those subprograms that
 705          --  are needed requires that we perform a transitive closure over
 706          --  the call graph, starting from calls in the main program. Here
 707          --  we do one step of the inverse transitive closure, and reset
 708          --  the Is_Called flag on subprograms all of whose callers are not.
 709
 710          for Index in Inlined.First .. Inlined.Last loop
 711             S := Inlined.Table (Index).First_Succ;
 712
 713             if S /= No_Succ
 714               and then not Inlined.Table (Index).Main_Call
 715             then
 716                Set_Is_Called (Inlined.Table (Index).Name, False);
 717
 718                while S /= No_Succ loop
 719                   if Is_Called
 720                     (Inlined.Table (Successors.Table (S).Subp).Name)
 721                    or else Inlined.Table (Successors.Table (S).Subp).Main_Call
 722                   then
 723                      Set_Is_Called (Inlined.Table (Index).Name);
 724                      exit;
 725                   end if;
 726
 727                   S := Successors.Table (S).Next;
 728                end loop;
 729             end if;
 730          end loop;
 731
 732          --  Now that the units are compiled, chain the subprograms within
 733          --  that are called and inlined. Produce list of inlined subprograms
 734          --  sorted in  topological order. Start with all subprograms that
 735          --  have no prerequisites, i.e. inlined subprograms that do not call
 736          --  other inlined subprograms.
 737
 738          for Index in Inlined.First .. Inlined.Last loop
 739
 740             if Is_Called (Inlined.Table (Index).Name)
 741               and then Inlined.Table (Index).Count = 0
 742               and then not Inlined.Table (Index).Listed
 743             then
 744                Add_Inlined_Subprogram (Index);
 745             end if;
 746          end loop;
 747
 748          --  Because Add_Inlined_Subprogram treats recursively nodes that have
 749          --  no prerequisites left, at the end of the loop all subprograms
 750          --  must have been listed. If there are any unlisted subprograms
 751          --  left, there must be some recursive chains that cannot be inlined.
 752
 753          for Index in Inlined.First .. Inlined.Last loop
 754             if Is_Called (Inlined.Table (Index).Name)
 755               and then Inlined.Table (Index).Count /= 0
 756               and then not Is_Predefined_File_Name
 757                 (Unit_File_Name
 758                   (Get_Source_Unit (Inlined.Table (Index).Name)))
 759             then
 760                Error_Msg_N
 761                  ("& cannot be inlined?", Inlined.Table (Index).Name);
 762
 763                --  A warning on the first one might be sufficient ???
 764             end if;
 765          end loop;
 766
 767          Pop_Scope;
 768       end if;
 769    end Analyze_Inlined_Bodies;
 770
 771    -----------------------------
 772    -- Check_Body_For_Inlining --
 773    -----------------------------
 774
 775    procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
 776       Bname : Unit_Name_Type;
 777       E     : Entity_Id;
 778       OK    : Boolean;
 779
 780    begin
 781       if Is_Compilation_Unit (P)
 782         and then not Is_Generic_Instance (P)
 783       then
 784          Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
 785
 786          E := First_Entity (P);
 787          while Present (E) loop
 788             if Has_Pragma_Inline_Always (E)
 789               or else (Front_End_Inlining and then Has_Pragma_Inline (E))
 790             then
 791                if not Is_Loaded (Bname) then
 792                   Load_Needed_Body (N, OK);
 793
 794                   if OK then
 795
 796                      --  Check we are not trying to inline a parent whose body
 797                      --  depends on a child, when we are compiling the body of
 798                      --  the child. Otherwise we have a potential elaboration
 799                      --  circularity with inlined subprograms and with
 800                      --  Taft-Amendment types.
 801
 802                      declare
 803                         Comp        : Node_Id;      --  Body just compiled
 804                         Child_Spec  : Entity_Id;    --  Spec of main unit
 805                         Ent         : Entity_Id;    --  For iteration
 806                         With_Clause : Node_Id;      --  Context of body.
 807
 808                      begin
 809                         if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
 810                           and then Present (Body_Entity (P))
 811                         then
 812                            Child_Spec :=
 813                              Defining_Entity
 814                                ((Unit (Library_Unit (Cunit (Main_Unit)))));
 815
 816                            Comp :=
 817                              Parent (Unit_Declaration_Node (Body_Entity (P)));
 818
 819                            --  Check whether the context of the body just
 820                            --  compiled includes a child of itself, and that
 821                            --  child is the spec of the main compilation.
 822
 823                            With_Clause := First (Context_Items (Comp));
 824                            while Present (With_Clause) loop
 825                               if Nkind (With_Clause) = N_With_Clause
 826                                 and then
 827                                   Scope (Entity (Name (With_Clause))) = P
 828                                 and then
 829                                   Entity (Name (With_Clause)) = Child_Spec
 830                               then
 831                                  Error_Msg_Node_2 := Child_Spec;
 832                                  Error_Msg_NE
 833                                    ("body of & depends on child unit&?",
 834                                       With_Clause, P);
 835                                  Error_Msg_N
 836                                    ("\subprograms in body cannot be inlined?",
 837                                       With_Clause);
 838
 839                                  --  Disable further inlining from this unit,
 840                                  --  and keep Taft-amendment types incomplete.
 841
 842                                  Ent := First_Entity (P);
 843                                  while Present (Ent) loop
 844                                     if Is_Type (Ent)
 845                                        and then Has_Completion_In_Body (Ent)
 846                                     then
 847                                        Set_Full_View (Ent, Empty);
 848
 849                                     elsif Is_Subprogram (Ent) then
 850                                        Set_Is_Inlined (Ent, False);
 851                                     end if;
 852
 853                                     Next_Entity (Ent);
 854                                  end loop;
 855
 856                                  return;
 857                               end if;
 858
 859                               Next (With_Clause);
 860                            end loop;
 861                         end if;
 862                      end;
 863
 864                   elsif Ineffective_Inline_Warnings then
 865                      Error_Msg_Unit_1 := Bname;
 866                      Error_Msg_N
 867                        ("unable to inline subprograms defined in $?", P);
 868                      Error_Msg_N ("\body not found?", P);
 869                      return;
 870                   end if;
 871                end if;
 872
 873                return;
 874             end if;
 875
 876             Next_Entity (E);
 877          end loop;
 878       end if;
 879    end Check_Body_For_Inlining;
 880
 881    --------------------
 882    -- Cleanup_Scopes --
 883    --------------------
 884
 885    procedure Cleanup_Scopes is
 886       Elmt : Elmt_Id;
 887       Decl : Node_Id;
 888       Scop : Entity_Id;
 889
 890    begin
 891       Elmt := First_Elmt (To_Clean);
 892       while Present (Elmt) loop
 893          Scop := Node (Elmt);
 894
 895          if Ekind (Scop) = E_Entry then
 896             Scop := Protected_Body_Subprogram (Scop);
 897
 898          elsif Is_Subprogram (Scop)
 899            and then Is_Protected_Type (Scope (Scop))
 900            and then Present (Protected_Body_Subprogram (Scop))
 901          then
 902             --  If a protected operation contains an instance, its
 903             --  cleanup operations have been delayed, and the subprogram
 904             --  has been rewritten in the expansion of the enclosing
 905             --  protected body. It is the corresponding subprogram that
 906             --  may require the cleanup operations, so propagate the
 907             --  information that triggers cleanup activity.
 908
 909             Set_Uses_Sec_Stack
 910               (Protected_Body_Subprogram (Scop),
 911                 Uses_Sec_Stack (Scop));
 912             Set_Finalization_Chain_Entity
 913               (Protected_Body_Subprogram (Scop),
 914                 Finalization_Chain_Entity (Scop));
 915             Scop := Protected_Body_Subprogram (Scop);
 916          end if;
 917
 918          if Ekind (Scop) = E_Block then
 919             Decl := Parent (Block_Node (Scop));
 920
 921          else
 922             Decl := Unit_Declaration_Node (Scop);
 923
 924             if Nkind (Decl) = N_Subprogram_Declaration
 925               or else Nkind (Decl) = N_Task_Type_Declaration
 926               or else Nkind (Decl) = N_Subprogram_Body_Stub
 927             then
 928                Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
 929             end if;
 930          end if;
 931
 932          Push_Scope (Scop);
 933          Expand_Cleanup_Actions (Decl);
 934          End_Scope;
 935
 936          Elmt := Next_Elmt (Elmt);
 937       end loop;
 938    end Cleanup_Scopes;
 939
 940    --------------------------
 941    -- Has_Initialized_Type --
 942    --------------------------
 943
 944    function Has_Initialized_Type (E : Entity_Id) return Boolean is
 945       E_Body : constant Node_Id := Get_Subprogram_Body (E);
 946       Decl   : Node_Id;
 947
 948    begin
 949       if No (E_Body) then        --  imported subprogram
 950          return False;
 951
 952       else
 953          Decl := First (Declarations (E_Body));
 954          while Present (Decl) loop
 955
 956             if Nkind (Decl) = N_Full_Type_Declaration
 957               and then Present (Init_Proc (Defining_Identifier (Decl)))
 958             then
 959                return True;
 960             end if;
 961
 962             Next (Decl);
 963          end loop;
 964       end if;
 965
 966       return False;
 967    end Has_Initialized_Type;
 968
 969    ----------------
 970    -- Initialize --
 971    ----------------
 972
 973    procedure Initialize is
 974    begin
 975       Analyzing_Inlined_Bodies := False;
 976       Pending_Descriptor.Init;
 977       Pending_Instantiations.Init;
 978       Inlined_Bodies.Init;
 979       Successors.Init;
 980       Inlined.Init;
 981
 982       for J in Hash_Headers'Range loop
 983          Hash_Headers (J) := No_Subp;
 984       end loop;
 985    end Initialize;
 986
 987    ------------------------
 988    -- Instantiate_Bodies --
 989    ------------------------
 990
 991    --  Generic bodies contain all the non-local references, so an
 992    --  instantiation does not need any more context than Standard
 993    --  itself, even if the instantiation appears in an inner scope.
 994    --  Generic associations have verified that the contract model is
 995    --  satisfied, so that any error that may occur in the analysis of
 996    --  the body is an internal error.
 997
 998    procedure Instantiate_Bodies is
 999       J    : Int;
1000       Info : Pending_Body_Info;
1001
1002    begin
1003       if Serious_Errors_Detected = 0 then
1004
1005          Expander_Active := (Operating_Mode = Opt.Generate_Code);
1006          Push_Scope (Standard_Standard);
1007          To_Clean := New_Elmt_List;
1008
1009          if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
1010             Start_Generic;
1011          end if;
1012
1013          --  A body instantiation may generate additional instantiations, so
1014          --  the following loop must scan to the end of a possibly expanding
1015          --  set (that's why we can't simply use a FOR loop here).
1016
1017          J := 0;
1018          while J <= Pending_Instantiations.Last
1019            and then Serious_Errors_Detected = 0
1020          loop
1021             Info := Pending_Instantiations.Table (J);
1022
1023             --  If the instantiation node is absent, it has been removed
1024             --  as part of unreachable code.
1025
1026             if No (Info.Inst_Node) then
1027                null;
1028
1029             elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
1030                Instantiate_Package_Body (Info);
1031                Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
1032
1033             else
1034                Instantiate_Subprogram_Body (Info);
1035             end if;
1036
1037             J := J + 1;
1038          end loop;
1039
1040          --  Reset the table of instantiations. Additional instantiations
1041          --  may be added through inlining, when additional bodies are
1042          --  analyzed.
1043
1044          Pending_Instantiations.Init;
1045
1046          --  We can now complete the cleanup actions of scopes that contain
1047          --  pending instantiations (skipped for generic units, since we
1048          --  never need any cleanups in generic units).
1049          --  pending instantiations.
1050
1051          if Expander_Active
1052            and then not Is_Generic_Unit (Main_Unit_Entity)
1053          then
1054             Cleanup_Scopes;
1055          elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
1056             End_Generic;
1057          end if;
1058
1059          Pop_Scope;
1060       end if;
1061    end Instantiate_Bodies;
1062
1063    ---------------
1064    -- Is_Nested --
1065    ---------------
1066
1067    function Is_Nested (E : Entity_Id) return Boolean is
1068       Scop : Entity_Id;
1069
1070    begin
1071       Scop := Scope (E);
1072       while Scop /= Standard_Standard loop
1073          if Ekind (Scop) in Subprogram_Kind then
1074             return True;
1075
1076          elsif Ekind (Scop) = E_Task_Type
1077            or else Ekind (Scop) = E_Entry
1078            or else Ekind (Scop) = E_Entry_Family then
1079             return True;
1080          end if;
1081
1082          Scop := Scope (Scop);
1083       end loop;
1084
1085       return False;
1086    end Is_Nested;
1087
1088    ----------
1089    -- Lock --
1090    ----------
1091
1092    procedure Lock is
1093    begin
1094       Pending_Instantiations.Locked := True;
1095       Inlined_Bodies.Locked := True;
1096       Successors.Locked := True;
1097       Inlined.Locked := True;
1098       Pending_Instantiations.Release;
1099       Inlined_Bodies.Release;
1100       Successors.Release;
1101       Inlined.Release;
1102    end Lock;
1103
1104    --------------------------
1105    -- Remove_Dead_Instance --
1106    --------------------------
1107
1108    procedure Remove_Dead_Instance (N : Node_Id) is
1109       J : Int;
1110
1111    begin
1112       J := 0;
1113       while J <= Pending_Instantiations.Last loop
1114          if Pending_Instantiations.Table (J).Inst_Node = N then
1115             Pending_Instantiations.Table (J).Inst_Node := Empty;
1116             return;
1117          end if;
1118
1119          J := J + 1;
1120       end loop;
1121    end Remove_Dead_Instance;
1122
1123    ------------------------
1124    -- Scope_In_Main_Unit --
1125    ------------------------
1126
1127    function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is
1128       Comp : Node_Id;
1129       S    : Entity_Id;
1130       Ent  : Entity_Id := Cunit_Entity (Main_Unit);
1131
1132    begin
1133       --  The scope may be within the main unit, or it may be an ancestor
1134       --  of the main unit, if the main unit is a child unit. In both cases
1135       --  it makes no sense to process the body before the main unit. In
1136       --  the second case, this may lead to circularities if a parent body
1137       --  depends on a child spec, and we are analyzing the child.
1138
1139       S := Scop;
1140       while Scope (S) /= Standard_Standard
1141         and then not Is_Child_Unit (S)
1142       loop
1143          S := Scope (S);
1144       end loop;
1145
1146       Comp := Parent (S);
1147       while Present (Comp)
1148         and then Nkind (Comp) /= N_Compilation_Unit
1149       loop
1150          Comp := Parent (Comp);
1151       end loop;
1152
1153       if Is_Child_Unit (Ent) then
1154          while Present (Ent)
1155            and then Is_Child_Unit (Ent)
1156          loop
1157             if Scope (Ent) = S then
1158                return True;
1159             end if;
1160
1161             Ent := Scope (Ent);
1162          end loop;
1163       end if;
1164
1165       return
1166         Comp = Cunit (Main_Unit)
1167           or else Comp = Library_Unit (Cunit (Main_Unit));
1168    end Scope_In_Main_Unit;
1169
1170 end Inline;