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