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-2008, 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_Ch8;  use Sem_Ch8;
  39 with Sem_Ch10; use Sem_Ch10;
  40 with Sem_Ch12; use Sem_Ch12;
  41 with Sem_Util; use Sem_Util;
  42 with Sinfo;    use Sinfo;
  43 with Snames;   use Snames;
  44 with Stand;    use Stand;
  45 with Uname;    use Uname;
  46
  47 package 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 a prerequisite 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 produce a list of subprograms in  topological order, for use by the
  77    --  back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for
  78    --  proper inlining the back-end must analyze the body of P2 before that of
  79    --  P1. The code below guarantees that the transitive closure of inlined
  80    --  subprograms called from the main compilation unit is made available to
  81    --  the code generator.
  82
  83    Last_Inlined : Entity_Id := Empty;
  84
  85    --  For each entry in the table we keep a list of successors in topological
  86    --  order, i.e. callers of the current subprogram.
  87
  88    type Subp_Index is new Nat;
  89    No_Subp : constant Subp_Index := 0;
  90
  91    --  The subprogram entities are hashed into the Inlined table
  92
  93    Num_Hash_Headers : constant := 512;
  94
  95    Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
  96                                                           of Subp_Index;
  97
  98    type Succ_Index is new Nat;
  99    No_Succ : constant Succ_Index := 0;
 100
 101    type Succ_Info is record
 102       Subp : Subp_Index;
 103       Next : Succ_Index;
 104    end record;
 105
 106    --  The following table stores list elements for the successor lists.
 107    --  These lists cannot be chained directly through entries in the Inlined
 108    --  table, because a given subprogram can appear in several such lists.
 109
 110    package Successors is new Table.Table (
 111       Table_Component_Type => Succ_Info,
 112       Table_Index_Type     => Succ_Index,
 113       Table_Low_Bound      => 1,
 114       Table_Initial        => Alloc.Successors_Initial,
 115       Table_Increment      => Alloc.Successors_Increment,
 116       Table_Name           => "Successors");
 117
 118    type Subp_Info is record
 119       Name        : Entity_Id  := Empty;
 120       First_Succ  : Succ_Index := No_Succ;
 121       Count       : Integer    := 0;
 122       Listed      : Boolean    := False;
 123       Main_Call   : Boolean    := False;
 124       Next        : Subp_Index := No_Subp;
 125       Next_Nopred : Subp_Index := No_Subp;
 126    end record;
 127
 128    package Inlined is new Table.Table (
 129       Table_Component_Type => Subp_Info,
 130       Table_Index_Type     => Subp_Index,
 131       Table_Low_Bound      => 1,
 132       Table_Initial        => Alloc.Inlined_Initial,
 133       Table_Increment      => Alloc.Inlined_Increment,
 134       Table_Name           => "Inlined");
 135
 136    -----------------------
 137    -- Local Subprograms --
 138    -----------------------
 139
 140    function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean;
 141    --  Return True if Scop is in the main unit or its spec, or in a
 142    --  parent of the main unit if it is a child unit.
 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 subprogram to Inlined List once all of its predecessors have been
 167    --  placed on the list. Decrement the count of all its successors, and
 168    --  add them to list (recursively) if count drops to zero.
 169
 170    ------------------------------
 171    -- Deferred Cleanup Actions --
 172    ------------------------------
 173
 174    --  The cleanup actions for scopes that contain instantiations is delayed
 175    --  until after expansion of those instantiations, because they may
 176    --  contain finalizable objects or tasks that affect the cleanup code.
 177    --  A scope that contains instantiations only needs to be finalized once,
 178    --  even if it contains more than one instance. We keep a list of scopes
 179    --  that must still be finalized, and call cleanup_actions after all the
 180    --  instantiations have been completed.
 181
 182    To_Clean : Elist_Id;
 183
 184    procedure Add_Scope_To_Clean (Inst : Entity_Id);
 185    --  Build set of scopes on which cleanup actions must be performed
 186
 187    procedure Cleanup_Scopes;
 188    --  Complete cleanup actions on scopes that need it
 189
 190    --------------
 191    -- Add_Call --
 192    --------------
 193
 194    procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
 195       P1 : constant Subp_Index := Add_Subp (Called);
 196       P2 : Subp_Index;
 197       J  : Succ_Index;
 198
 199    begin
 200       if Present (Caller) then
 201          P2 := Add_Subp (Caller);
 202
 203          --  Add P2 to the list of successors of P1, if not already there.
 204          --  Note that P2 may contain more than one call to P1, and only
 205          --  one needs to be recorded.
 206
 207          J := Inlined.Table (P1).First_Succ;
 208
 209          while J /= No_Succ loop
 210
 211             if Successors.Table (J).Subp = P2 then
 212                return;
 213             end if;
 214
 215             J := Successors.Table (J).Next;
 216          end loop;
 217
 218          --  On exit, make a successor entry for P2
 219
 220          Successors.Increment_Last;
 221          Successors.Table (Successors.Last).Subp := P2;
 222          Successors.Table (Successors.Last).Next :=
 223                              Inlined.Table (P1).First_Succ;
 224          Inlined.Table (P1).First_Succ := Successors.Last;
 225
 226          Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1;
 227
 228       else
 229          Inlined.Table (P1).Main_Call := True;
 230       end if;
 231    end Add_Call;
 232
 233    ----------------------
 234    -- Add_Inlined_Body --
 235    ----------------------
 236
 237    procedure Add_Inlined_Body (E : Entity_Id) is
 238       Pack : Entity_Id;
 239
 240       function Must_Inline return Boolean;
 241       --  Inlining is only done if the call statement N is in the main unit,
 242       --  or within the body of another inlined subprogram.
 243
 244       -----------------
 245       -- Must_Inline --
 246       -----------------
 247
 248       function Must_Inline return Boolean is
 249          Scop : Entity_Id;
 250          Comp : Node_Id;
 251
 252       begin
 253          --  Check if call is in main unit
 254
 255          Scop := Current_Scope;
 256
 257          --  Do not try to inline if scope is standard. This could happen, for
 258          --  example, for a call to Add_Global_Declaration, and it causes
 259          --  trouble to try to inline at this level.
 260
 261          if Scop = Standard_Standard then
 262             return False;
 263          end if;
 264
 265          --  Otherwise lookup scope stack to outer scope
 266
 267          while Scope (Scop) /= Standard_Standard
 268            and then not Is_Child_Unit (Scop)
 269          loop
 270             Scop := Scope (Scop);
 271          end loop;
 272
 273          Comp := Parent (Scop);
 274          while Nkind (Comp) /= N_Compilation_Unit loop
 275             Comp := Parent (Comp);
 276          end loop;
 277
 278          if Comp = Cunit (Main_Unit)
 279            or else Comp = Library_Unit (Cunit (Main_Unit))
 280          then
 281             Add_Call (E);
 282             return True;
 283          end if;
 284
 285          --  Call is not in main unit. See if it's in some inlined subprogram
 286
 287          Scop := Current_Scope;
 288          while Scope (Scop) /= Standard_Standard
 289            and then not Is_Child_Unit (Scop)
 290          loop
 291             if Is_Overloadable (Scop)
 292               and then Is_Inlined (Scop)
 293             then
 294                Add_Call (E, Scop);
 295                return True;
 296             end if;
 297
 298             Scop := Scope (Scop);
 299          end loop;
 300
 301          return False;
 302       end Must_Inline;
 303
 304    --  Start of processing for Add_Inlined_Body
 305
 306    begin
 307       --  Find unit containing E, and add to list of inlined bodies if needed.
 308       --  If the body is already present, no need to load any other unit. This
 309       --  is the case for an initialization procedure, which appears in the
 310       --  package declaration that contains the type. It is also the case if
 311       --  the body has already been analyzed. Finally, if the unit enclosing
 312       --  E is an instance, the instance body will be analyzed in any case,
 313       --  and there is no need to add the enclosing unit (whose body might not
 314       --  be available).
 315
 316       --  Library-level functions must be handled specially, because there is
 317       --  no enclosing package to retrieve. In this case, it is the body of
 318       --  the function that will have to be loaded.
 319
 320       if not Is_Abstract_Subprogram (E) and then not Is_Nested (E)
 321         and then Convention (E) /= Convention_Protected
 322       then
 323          Pack := Scope (E);
 324
 325          if Must_Inline
 326            and then Ekind (Pack) = E_Package
 327          then
 328             Set_Is_Called (E);
 329
 330             if Pack = Standard_Standard then
 331
 332                --  Library-level inlined function. Add function itself to
 333                --  list of needed units.
 334
 335                Inlined_Bodies.Increment_Last;
 336                Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
 337
 338             elsif Is_Generic_Instance (Pack) then
 339                null;
 340
 341             elsif not Is_Inlined (Pack)
 342               and then not Has_Completion (E)
 343               and then not Scope_In_Main_Unit (Pack)
 344             then
 345                Set_Is_Inlined (Pack);
 346                Inlined_Bodies.Increment_Last;
 347                Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
 348             end if;
 349          end if;
 350       end if;
 351    end Add_Inlined_Body;
 352
 353    ----------------------------
 354    -- Add_Inlined_Subprogram --
 355    ----------------------------
 356
 357    procedure Add_Inlined_Subprogram (Index : Subp_Index) is
 358       E    : constant Entity_Id := Inlined.Table (Index).Name;
 359       Succ : Succ_Index;
 360       Subp : Subp_Index;
 361
 362       function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
 363       --  There are various conditions under which back-end inlining cannot
 364       --  be done reliably:
 365       --
 366       --    a) If a body has handlers, it must not be inlined, because this
 367       --    may violate program semantics, and because in zero-cost exception
 368       --    mode it will lead to undefined symbols at link time.
 369       --
 370       --    b) If a body contains inlined function instances, it cannot be
 371       --    inlined under ZCX because the numeric suffix generated by gigi
 372       --    will be different in the body and the place of the inlined call.
 373       --
 374       --  If the body to be inlined contains calls to subprograms declared
 375       --  in the same body that have no previous spec, the back-end cannot
 376       --  inline either because the bodies to be inlined are processed before
 377       --  the rest of the enclosing package body, and gigi will then find
 378       --  references to entities that have not been elaborated yet.
 379       --
 380       --  This procedure must be carefully coordinated with the back end.
 381
 382       ----------------------------
 383       -- Back_End_Cannot_Inline --
 384       ----------------------------
 385
 386       function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
 387          Decl     : constant Node_Id := Unit_Declaration_Node (Subp);
 388          Body_Ent : Entity_Id;
 389          Ent      : Entity_Id;
 390          Bad_Call : Node_Id;
 391
 392          function Process (N : Node_Id) return Traverse_Result;
 393          --  Look for calls to subprograms with no previous spec, declared
 394          --  in the same enclosiong package body.
 395
 396          -------------
 397          -- Process --
 398          -------------
 399
 400          function Process (N : Node_Id) return Traverse_Result is
 401          begin
 402             if Nkind (N) = N_Procedure_Call_Statement
 403               or else Nkind (N) = N_Function_Call
 404             then
 405                if Is_Entity_Name (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       Succ := Inlined.Table (Index).First_Succ;
 502       while Succ /= No_Succ loop
 503          Subp := Successors.Table (Succ).Subp;
 504          Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;
 505
 506          if Inlined.Table (Subp).Count = 0 then
 507             Add_Inlined_Subprogram (Subp);
 508          end if;
 509
 510          Succ := Successors.Table (Succ).Next;
 511       end loop;
 512    end Add_Inlined_Subprogram;
 513
 514    ------------------------
 515    -- Add_Scope_To_Clean --
 516    ------------------------
 517
 518    procedure Add_Scope_To_Clean (Inst : Entity_Id) is
 519       Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
 520       Elmt : Elmt_Id;
 521
 522    begin
 523       --  If the instance appears in a library-level package declaration,
 524       --  all finalization is global, and nothing needs doing here.
 525
 526       if Scop = Standard_Standard then
 527          return;
 528       end if;
 529
 530       --  If the instance appears within a generic subprogram there is nothing
 531       --  to finalize either.
 532
 533       declare
 534          S : Entity_Id;
 535       begin
 536          S := Scope (Inst);
 537          while Present (S) and then S /= Standard_Standard loop
 538             if Is_Generic_Subprogram (S) then
 539                return;
 540             end if;
 541
 542             S := Scope (S);
 543          end loop;
 544       end;
 545
 546       Elmt := First_Elmt (To_Clean);
 547
 548       while Present (Elmt) loop
 549
 550          if Node (Elmt) = Scop then
 551             return;
 552          end if;
 553
 554          Elmt := Next_Elmt (Elmt);
 555       end loop;
 556
 557       Append_Elmt (Scop, To_Clean);
 558    end Add_Scope_To_Clean;
 559
 560    --------------
 561    -- Add_Subp --
 562    --------------
 563
 564    function Add_Subp (E : Entity_Id) return Subp_Index is
 565       Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
 566       J     : Subp_Index;
 567
 568       procedure New_Entry;
 569       --  Initialize entry in Inlined table
 570
 571       procedure New_Entry is
 572       begin
 573          Inlined.Increment_Last;
 574          Inlined.Table (Inlined.Last).Name        := E;
 575          Inlined.Table (Inlined.Last).First_Succ  := No_Succ;
 576          Inlined.Table (Inlined.Last).Count       := 0;
 577          Inlined.Table (Inlined.Last).Listed      := False;
 578          Inlined.Table (Inlined.Last).Main_Call   := False;
 579          Inlined.Table (Inlined.Last).Next        := No_Subp;
 580          Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
 581       end New_Entry;
 582
 583    --  Start of processing for Add_Subp
 584
 585    begin
 586       if Hash_Headers (Index) = No_Subp then
 587          New_Entry;
 588          Hash_Headers (Index) := Inlined.Last;
 589          return Inlined.Last;
 590
 591       else
 592          J := Hash_Headers (Index);
 593
 594          while J /= No_Subp loop
 595
 596             if Inlined.Table (J).Name = E then
 597                return J;
 598             else
 599                Index := J;
 600                J := Inlined.Table (J).Next;
 601             end if;
 602          end loop;
 603
 604          --  On exit, subprogram was not found. Enter in table. Index is
 605          --  the current last entry on the hash chain.
 606
 607          New_Entry;
 608          Inlined.Table (Index).Next := Inlined.Last;
 609          return Inlined.Last;
 610       end if;
 611    end Add_Subp;
 612
 613    ----------------------------
 614    -- Analyze_Inlined_Bodies --
 615    ----------------------------
 616
 617    procedure Analyze_Inlined_Bodies is
 618       Comp_Unit : Node_Id;
 619       J         : Int;
 620       Pack      : Entity_Id;
 621       S         : Succ_Index;
 622
 623    begin
 624       Analyzing_Inlined_Bodies := False;
 625
 626       if Serious_Errors_Detected = 0 then
 627          Push_Scope (Standard_Standard);
 628
 629          J := 0;
 630          while J <= Inlined_Bodies.Last
 631            and then Serious_Errors_Detected = 0
 632          loop
 633             Pack := Inlined_Bodies.Table (J);
 634
 635             while Present (Pack)
 636               and then Scope (Pack) /= Standard_Standard
 637               and then not Is_Child_Unit (Pack)
 638             loop
 639                Pack := Scope (Pack);
 640             end loop;
 641
 642             Comp_Unit := Parent (Pack);
 643             while Present (Comp_Unit)
 644               and then Nkind (Comp_Unit) /= N_Compilation_Unit
 645             loop
 646                Comp_Unit := Parent (Comp_Unit);
 647             end loop;
 648
 649             --  Load the body, unless it the main unit, or is an instance
 650             --  whose body has already been analyzed.
 651
 652             if Present (Comp_Unit)
 653               and then Comp_Unit /= Cunit (Main_Unit)
 654               and then Body_Required (Comp_Unit)
 655               and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
 656                          or else No (Corresponding_Body (Unit (Comp_Unit))))
 657             then
 658                declare
 659                   Bname : constant Unit_Name_Type :=
 660                             Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
 661
 662                   OK : Boolean;
 663
 664                begin
 665                   if not Is_Loaded (Bname) then
 666                      Load_Needed_Body (Comp_Unit, OK);
 667
 668                      if not OK then
 669
 670                         --  Warn that a body was not available for inlining
 671                         --  by the back-end.
 672
 673                         Error_Msg_Unit_1 := Bname;
 674                         Error_Msg_N
 675                           ("one or more inlined subprograms accessed in $!?",
 676                            Comp_Unit);
 677                         Error_Msg_File_1 :=
 678                           Get_File_Name (Bname, Subunit => False);
 679                         Error_Msg_N ("\but file{ was not found!?", Comp_Unit);
 680                      end if;
 681                   end if;
 682                end;
 683             end if;
 684
 685             J := J + 1;
 686          end loop;
 687
 688          --  The analysis of required bodies may have produced additional
 689          --  generic instantiations. To obtain further inlining, we perform
 690          --  another round of generic body instantiations. Establishing a
 691          --  fully recursive loop between inlining and generic instantiations
 692          --  is unlikely to yield more than this one additional pass.
 693
 694          Instantiate_Bodies;
 695
 696          --  The list of inlined subprograms is an overestimate, because
 697          --  it includes inlined functions called from functions that are
 698          --  compiled as part of an inlined package, but are not themselves
 699          --  called. An accurate computation of just those subprograms that
 700          --  are needed requires that we perform a transitive closure over
 701          --  the call graph, starting from calls in the main program. Here
 702          --  we do one step of the inverse transitive closure, and reset
 703          --  the Is_Called flag on subprograms all of whose callers are not.
 704
 705          for Index in Inlined.First .. Inlined.Last loop
 706             S := Inlined.Table (Index).First_Succ;
 707
 708             if S /= No_Succ
 709               and then not Inlined.Table (Index).Main_Call
 710             then
 711                Set_Is_Called (Inlined.Table (Index).Name, False);
 712
 713                while S /= No_Succ loop
 714
 715                   if Is_Called
 716                     (Inlined.Table (Successors.Table (S).Subp).Name)
 717                    or else Inlined.Table (Successors.Table (S).Subp).Main_Call
 718                   then
 719                      Set_Is_Called (Inlined.Table (Index).Name);
 720                      exit;
 721                   end if;
 722
 723                   S := Successors.Table (S).Next;
 724                end loop;
 725             end if;
 726          end loop;
 727
 728          --  Now that the units are compiled, chain the subprograms within
 729          --  that are called and inlined. Produce list of inlined subprograms
 730          --  sorted in  topological order. Start with all subprograms that
 731          --  have no prerequisites, i.e. inlined subprograms that do not call
 732          --  other inlined subprograms.
 733
 734          for Index in Inlined.First .. Inlined.Last loop
 735
 736             if Is_Called (Inlined.Table (Index).Name)
 737               and then Inlined.Table (Index).Count = 0
 738               and then not Inlined.Table (Index).Listed
 739             then
 740                Add_Inlined_Subprogram (Index);
 741             end if;
 742          end loop;
 743
 744          --  Because Add_Inlined_Subprogram treats recursively nodes that have
 745          --  no prerequisites left, at the end of the loop all subprograms
 746          --  must have been listed. If there are any unlisted subprograms
 747          --  left, there must be some recursive chains that cannot be inlined.
 748
 749          for Index in Inlined.First .. Inlined.Last loop
 750             if Is_Called (Inlined.Table (Index).Name)
 751               and then Inlined.Table (Index).Count /= 0
 752               and then not Is_Predefined_File_Name
 753                 (Unit_File_Name
 754                   (Get_Source_Unit (Inlined.Table (Index).Name)))
 755             then
 756                Error_Msg_N
 757                  ("& cannot be inlined?", Inlined.Table (Index).Name);
 758
 759                --  A warning on the first one might be sufficient ???
 760             end if;
 761          end loop;
 762
 763          Pop_Scope;
 764       end if;
 765    end Analyze_Inlined_Bodies;
 766
 767    -----------------------------
 768    -- Check_Body_For_Inlining --
 769    -----------------------------
 770
 771    procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
 772       Bname : Unit_Name_Type;
 773       E     : Entity_Id;
 774       OK    : Boolean;
 775
 776    begin
 777       if Is_Compilation_Unit (P)
 778         and then not Is_Generic_Instance (P)
 779       then
 780          Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
 781          E := First_Entity (P);
 782
 783          while Present (E) loop
 784             if Has_Pragma_Inline_Always (E)
 785               or else (Front_End_Inlining and then Has_Pragma_Inline (E))
 786             then
 787                if not Is_Loaded (Bname) then
 788                   Load_Needed_Body (N, OK);
 789
 790                   if OK then
 791
 792                      --  Check that we are not trying to inline a parent
 793                      --  whose body depends on a child, when we are compiling
 794                      --  the body of the child. Otherwise we have a potential
 795                      --  elaboration circularity with inlined subprograms and
 796                      --  with Taft-Amendment types.
 797
 798                      declare
 799                         Comp        : Node_Id;      --  Body just compiled
 800                         Child_Spec  : Entity_Id;    --  Spec of main unit
 801                         Ent         : Entity_Id;    --  For iteration
 802                         With_Clause : Node_Id;      --  Context of body.
 803
 804                      begin
 805                         if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
 806                           and then Present (Body_Entity (P))
 807                         then
 808                            Child_Spec :=
 809                              Defining_Entity (
 810                                (Unit (Library_Unit (Cunit (Main_Unit)))));
 811
 812                            Comp :=
 813                              Parent (Unit_Declaration_Node (Body_Entity (P)));
 814
 815                            With_Clause := First (Context_Items (Comp));
 816
 817                            --  Check whether the context of the body just
 818                            --  compiled includes a child of itself, and that
 819                            --  child is the spec of the main compilation.
 820
 821                            while Present (With_Clause) loop
 822                               if Nkind (With_Clause) = N_With_Clause
 823                                 and then
 824                                   Scope (Entity (Name (With_Clause))) = P
 825                                 and then
 826                                   Entity (Name (With_Clause)) = Child_Spec
 827                               then
 828                                  Error_Msg_Node_2 := Child_Spec;
 829                                  Error_Msg_NE
 830                                    ("body of & depends on child unit&?",
 831                                       With_Clause, P);
 832                                  Error_Msg_N
 833                                    ("\subprograms in body cannot be inlined?",
 834                                       With_Clause);
 835
 836                                  --  Disable further inlining from this unit,
 837                                  --  and keep Taft-amendment types incomplete.
 838
 839                                  Ent := First_Entity (P);
 840
 841                                  while Present (Ent) loop
 842                                     if Is_Type (Ent)
 843                                        and then Has_Completion_In_Body (Ent)
 844                                     then
 845                                        Set_Full_View (Ent, Empty);
 846
 847                                     elsif Is_Subprogram (Ent) then
 848                                        Set_Is_Inlined (Ent, False);
 849                                     end if;
 850
 851                                     Next_Entity (Ent);
 852                                  end loop;
 853
 854                                  return;
 855                               end if;
 856
 857                               Next (With_Clause);
 858                            end loop;
 859                         end if;
 860                      end;
 861
 862                   elsif Ineffective_Inline_Warnings then
 863                      Error_Msg_Unit_1 := Bname;
 864                      Error_Msg_N
 865                        ("unable to inline subprograms defined in $?", P);
 866                      Error_Msg_N ("\body not found?", P);
 867                      return;
 868                   end if;
 869                end if;
 870
 871                return;
 872             end if;
 873
 874             Next_Entity (E);
 875          end loop;
 876       end if;
 877    end Check_Body_For_Inlining;
 878
 879    --------------------
 880    -- Cleanup_Scopes --
 881    --------------------
 882
 883    procedure Cleanup_Scopes is
 884       Elmt : Elmt_Id;
 885       Decl : Node_Id;
 886       Scop : Entity_Id;
 887
 888    begin
 889       Elmt := First_Elmt (To_Clean);
 890
 891       while Present (Elmt) loop
 892          Scop := Node (Elmt);
 893
 894          if Ekind (Scop) = E_Entry then
 895             Scop := Protected_Body_Subprogram (Scop);
 896
 897          elsif Is_Subprogram (Scop)
 898            and then Is_Protected_Type (Scope (Scop))
 899            and then Present (Protected_Body_Subprogram (Scop))
 900          then
 901             --  If a protected operation contains an instance, its
 902             --  cleanup operations have been delayed, and the subprogram
 903             --  has been rewritten in the expansion of the enclosing
 904             --  protected body. It is the corresponding subprogram that
 905             --  may require the cleanup operations, so propagate the
 906             --  information that triggers cleanup activity.
 907
 908             Set_Uses_Sec_Stack
 909               (Protected_Body_Subprogram (Scop),
 910                 Uses_Sec_Stack (Scop));
 911             Set_Finalization_Chain_Entity
 912               (Protected_Body_Subprogram (Scop),
 913                 Finalization_Chain_Entity (Scop));
 914             Scop := Protected_Body_Subprogram (Scop);
 915          end if;
 916
 917          if Ekind (Scop) = E_Block then
 918             Decl := Parent (Block_Node (Scop));
 919
 920          else
 921             Decl := Unit_Declaration_Node (Scop);
 922
 923             if Nkind (Decl) = N_Subprogram_Declaration
 924               or else Nkind (Decl) = N_Task_Type_Declaration
 925               or else Nkind (Decl) = N_Subprogram_Body_Stub
 926             then
 927                Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
 928             end if;
 929          end if;
 930
 931          Push_Scope (Scop);
 932          Expand_Cleanup_Actions (Decl);
 933          End_Scope;
 934
 935          Elmt := Next_Elmt (Elmt);
 936       end loop;
 937    end Cleanup_Scopes;
 938
 939    --------------------------
 940    -- Has_Initialized_Type --
 941    --------------------------
 942
 943    function Has_Initialized_Type (E : Entity_Id) return Boolean is
 944       E_Body : constant Node_Id := Get_Subprogram_Body (E);
 945       Decl   : Node_Id;
 946
 947    begin
 948       if No (E_Body) then        --  imported subprogram
 949          return False;
 950
 951       else
 952          Decl := First (Declarations (E_Body));
 953
 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 := Scope (E);
1069
1070    begin
1071       while Scop /= Standard_Standard loop
1072          if Ekind (Scop) in Subprogram_Kind then
1073             return True;
1074
1075          elsif Ekind (Scop) = E_Task_Type
1076            or else Ekind (Scop) = E_Entry
1077            or else Ekind (Scop) = E_Entry_Family then
1078             return True;
1079          end if;
1080
1081          Scop := Scope (Scop);
1082       end loop;
1083
1084       return False;
1085    end Is_Nested;
1086
1087    ----------
1088    -- Lock --
1089    ----------
1090
1091    procedure Lock is
1092    begin
1093       Pending_Instantiations.Locked := True;
1094       Inlined_Bodies.Locked := True;
1095       Successors.Locked := True;
1096       Inlined.Locked := True;
1097       Pending_Instantiations.Release;
1098       Inlined_Bodies.Release;
1099       Successors.Release;
1100       Inlined.Release;
1101    end Lock;
1102
1103    --------------------------
1104    -- Remove_Dead_Instance --
1105    --------------------------
1106
1107    procedure Remove_Dead_Instance (N : Node_Id) is
1108       J    : Int;
1109
1110    begin
1111       J := 0;
1112
1113       while J <= Pending_Instantiations.Last loop
1114
1115          if Pending_Instantiations.Table (J).Inst_Node = N then
1116             Pending_Instantiations.Table (J).Inst_Node := Empty;
1117             return;
1118          end if;
1119
1120          J := J + 1;
1121       end loop;
1122    end Remove_Dead_Instance;
1123
1124    ------------------------
1125    -- Scope_In_Main_Unit --
1126    ------------------------
1127
1128    function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is
1129       Comp : Node_Id;
1130       S    : Entity_Id := Scop;
1131       Ent  : Entity_Id := Cunit_Entity (Main_Unit);
1132
1133    begin
1134       --  The scope may be within the main unit, or it may be an ancestor
1135       --  of the main unit, if the main unit is a child unit. In both cases
1136       --  it makes no sense to process the body before the main unit. In
1137       --  the second case, this may lead to circularities if a parent body
1138       --  depends on a child spec, and we are analyzing the child.
1139
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
1148       while Present (Comp)
1149         and then Nkind (Comp) /= N_Compilation_Unit
1150       loop
1151          Comp := Parent (Comp);
1152       end loop;
1153
1154       if Is_Child_Unit (Ent) then
1155
1156          while Present (Ent)
1157            and then Is_Child_Unit (Ent)
1158          loop
1159             if Scope (Ent) = S then
1160                return True;
1161             end if;
1162
1163             Ent := Scope (Ent);
1164          end loop;
1165       end if;
1166
1167       return
1168         Comp = Cunit (Main_Unit)
1169           or else Comp = Library_Unit (Cunit (Main_Unit));
1170    end Scope_In_Main_Unit;
1171
1172 end Inline;