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-2001 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Errout;   use Errout;
  31 with Exp_Ch7;  use Exp_Ch7;
  32 with Exp_Ch11; use Exp_Ch11;
  33 with Exp_Tss;  use Exp_Tss;
  34 with Fname;    use Fname;
  35 with Fname.UF; use Fname.UF;
  36 with Lib;      use Lib;
  37 with Nlists;   use Nlists;
  38 with Opt;      use Opt;
  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 : 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       Comp_Unit : Node_Id;
 241
 242       function Must_Inline return Boolean;
 243       --  Inlining is only done if the call statement N is in the main unit,
 244       --  or within the body of another inlined subprogram.
 245
 246       function Must_Inline return Boolean is
 247          Scop : Entity_Id := Current_Scope;
 248          Comp : Node_Id;
 249
 250       begin
 251          --  Check if call is in main unit.
 252
 253          while Scope (Scop) /= Standard_Standard
 254            and then not Is_Child_Unit (Scop)
 255          loop
 256             Scop := Scope (Scop);
 257          end loop;
 258
 259          Comp := Parent (Scop);
 260
 261          while Nkind (Comp) /= N_Compilation_Unit loop
 262             Comp := Parent (Comp);
 263          end loop;
 264
 265          if (Comp = Cunit (Main_Unit)
 266            or else Comp = Library_Unit (Cunit (Main_Unit)))
 267          then
 268             Add_Call (E);
 269             return True;
 270          end if;
 271
 272          --  Call is not in main unit. See if it's in some inlined
 273          --  subprogram.
 274
 275          Scop := Current_Scope;
 276          while Scope (Scop) /= Standard_Standard
 277            and then not Is_Child_Unit (Scop)
 278          loop
 279             if Is_Overloadable (Scop)
 280               and then Is_Inlined (Scop)
 281             then
 282                Add_Call (E, Scop);
 283                return True;
 284             end if;
 285
 286             Scop := Scope (Scop);
 287          end loop;
 288
 289          return False;
 290
 291       end Must_Inline;
 292
 293    --  Start of processing for Add_Inlined_Body
 294
 295    begin
 296       --  Find unit containing E, and add to list of inlined bodies if needed.
 297       --  If the body is already present, no need to load any other unit. This
 298       --  is the case for an initialization procedure, which appears in the
 299       --  package declaration that contains the type. It is also the case if
 300       --  the body has already been analyzed. Finally, if the unit enclosing
 301       --  E is an instance, the instance body will be analyzed in any case,
 302       --  and there is no need to add the enclosing unit (whose body might not
 303       --  be available).
 304
 305       --  Library-level functions must be handled specially, because there is
 306       --  no enclosing package to retrieve. In this case, it is the body of
 307       --  the function that will have to be loaded.
 308
 309       if not Is_Abstract (E) and then not Is_Nested (E)
 310         and then Convention (E) /= Convention_Protected
 311       then
 312          Pack := Scope (E);
 313
 314          if Must_Inline
 315            and then Ekind (Pack) = E_Package
 316          then
 317             Set_Is_Called (E);
 318             Comp_Unit := Parent (Pack);
 319
 320             if Pack = Standard_Standard then
 321
 322                --  Library-level inlined function. Add function iself to
 323                --  list of needed units.
 324
 325                Inlined_Bodies.Increment_Last;
 326                Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
 327
 328             elsif Is_Generic_Instance (Pack) then
 329                null;
 330
 331             elsif not Is_Inlined (Pack)
 332               and then not Has_Completion (E)
 333               and then not Scope_In_Main_Unit (Pack)
 334             then
 335                Set_Is_Inlined (Pack);
 336                Inlined_Bodies.Increment_Last;
 337                Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
 338             end if;
 339          end if;
 340       end if;
 341    end Add_Inlined_Body;
 342
 343    ----------------------------
 344    -- Add_Inlined_Subprogram --
 345    ----------------------------
 346
 347    procedure Add_Inlined_Subprogram (Index : Subp_Index) is
 348       E    : constant Entity_Id := Inlined.Table (Index).Name;
 349       Succ : Succ_Index;
 350       Subp : Subp_Index;
 351
 352    begin
 353       --  Insert the current subprogram in the list of inlined subprograms
 354
 355       if not Scope_In_Main_Unit (E)
 356         and then Is_Inlined (E)
 357         and then not Is_Nested (E)
 358         and then not Has_Initialized_Type (E)
 359       then
 360          if No (Last_Inlined) then
 361             Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
 362          else
 363             Set_Next_Inlined_Subprogram (Last_Inlined, E);
 364          end if;
 365
 366          Last_Inlined := E;
 367       end if;
 368
 369       Inlined.Table (Index).Listed := True;
 370       Succ := Inlined.Table (Index).First_Succ;
 371
 372       while Succ /= No_Succ loop
 373          Subp := Successors.Table (Succ).Subp;
 374          Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;
 375
 376          if Inlined.Table (Subp).Count = 0 then
 377             Add_Inlined_Subprogram (Subp);
 378          end if;
 379
 380          Succ := Successors.Table (Succ).Next;
 381       end loop;
 382    end Add_Inlined_Subprogram;
 383
 384    ------------------------
 385    -- Add_Scope_To_Clean --
 386    ------------------------
 387
 388    procedure Add_Scope_To_Clean (Inst : Entity_Id) is
 389       Elmt : Elmt_Id;
 390       Scop : Entity_Id := Enclosing_Dynamic_Scope (Inst);
 391
 392    begin
 393       --  If the instance appears in a library-level package declaration,
 394       --  all finalization is global, and nothing needs doing here.
 395
 396       if Scop = Standard_Standard then
 397          return;
 398       end if;
 399
 400       Elmt := First_Elmt (To_Clean);
 401
 402       while Present (Elmt) loop
 403
 404          if Node (Elmt) = Scop then
 405             return;
 406          end if;
 407
 408          Elmt := Next_Elmt (Elmt);
 409       end loop;
 410
 411       Append_Elmt (Scop, To_Clean);
 412    end Add_Scope_To_Clean;
 413
 414    --------------
 415    -- Add_Subp --
 416    --------------
 417
 418    function Add_Subp (E : Entity_Id) return Subp_Index is
 419       Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
 420       J     : Subp_Index;
 421
 422       procedure New_Entry;
 423       --  Initialize entry in Inlined table.
 424
 425       procedure New_Entry is
 426       begin
 427          Inlined.Increment_Last;
 428          Inlined.Table (Inlined.Last).Name        := E;
 429          Inlined.Table (Inlined.Last).First_Succ  := No_Succ;
 430          Inlined.Table (Inlined.Last).Count       := 0;
 431          Inlined.Table (Inlined.Last).Listed      := False;
 432          Inlined.Table (Inlined.Last).Main_Call   := False;
 433          Inlined.Table (Inlined.Last).Next        := No_Subp;
 434          Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
 435       end New_Entry;
 436
 437    --  Start of processing for Add_Subp
 438
 439    begin
 440       if Hash_Headers (Index) = No_Subp then
 441          New_Entry;
 442          Hash_Headers (Index) := Inlined.Last;
 443          return Inlined.Last;
 444
 445       else
 446          J := Hash_Headers (Index);
 447
 448          while J /= No_Subp loop
 449
 450             if Inlined.Table (J).Name = E then
 451                return J;
 452             else
 453                Index := J;
 454                J := Inlined.Table (J).Next;
 455             end if;
 456          end loop;
 457
 458          --  On exit, subprogram was not found. Enter in table. Index is
 459          --  the current last entry on the hash chain.
 460
 461          New_Entry;
 462          Inlined.Table (Index).Next := Inlined.Last;
 463          return Inlined.Last;
 464       end if;
 465    end Add_Subp;
 466
 467    ----------------------------
 468    -- Analyze_Inlined_Bodies --
 469    ----------------------------
 470
 471    procedure Analyze_Inlined_Bodies is
 472       Comp_Unit : Node_Id;
 473       J         : Int;
 474       Pack      : Entity_Id;
 475       S         : Succ_Index;
 476
 477    begin
 478       Analyzing_Inlined_Bodies := False;
 479
 480       if Serious_Errors_Detected = 0 then
 481          New_Scope (Standard_Standard);
 482
 483          J := 0;
 484          while J <= Inlined_Bodies.Last
 485            and then Serious_Errors_Detected = 0
 486          loop
 487             Pack := Inlined_Bodies.Table (J);
 488
 489             while Present (Pack)
 490               and then Scope (Pack) /= Standard_Standard
 491               and then not Is_Child_Unit (Pack)
 492             loop
 493                Pack := Scope (Pack);
 494             end loop;
 495
 496             Comp_Unit := Parent (Pack);
 497
 498             while Present (Comp_Unit)
 499               and then Nkind (Comp_Unit) /= N_Compilation_Unit
 500             loop
 501                Comp_Unit := Parent (Comp_Unit);
 502             end loop;
 503
 504             --  Load the body, unless it the main unit, or is an instance
 505             --  whose body has already been analyzed.
 506
 507             if Present (Comp_Unit)
 508               and then Comp_Unit /= Cunit (Main_Unit)
 509               and then Body_Required (Comp_Unit)
 510               and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
 511                          or else No (Corresponding_Body (Unit (Comp_Unit))))
 512             then
 513                declare
 514                   Bname : constant Unit_Name_Type :=
 515                             Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
 516
 517                   OK : Boolean;
 518
 519                begin
 520                   if not Is_Loaded (Bname) then
 521                      Load_Needed_Body (Comp_Unit, OK);
 522
 523                      if not OK then
 524                         Error_Msg_Unit_1 := Bname;
 525                         Error_Msg_N
 526                           ("one or more inlined subprograms accessed in $!",
 527                            Comp_Unit);
 528                         Error_Msg_Name_1 :=
 529                           Get_File_Name (Bname, Subunit => False);
 530                         Error_Msg_N ("\but file{ was not found!", Comp_Unit);
 531                         raise Unrecoverable_Error;
 532                      end if;
 533                   end if;
 534                end;
 535             end if;
 536
 537             J := J + 1;
 538          end loop;
 539
 540          --  The analysis of required bodies may have produced additional
 541          --  generic instantiations. To obtain further inlining, we perform
 542          --  another round of generic body instantiations. Establishing a
 543          --  fully recursive loop between inlining and generic instantiations
 544          --  is unlikely to yield more than this one additional pass.
 545
 546          Instantiate_Bodies;
 547
 548          --  The list of inlined subprograms is an overestimate, because
 549          --  it includes inlined functions called from functions that are
 550          --  compiled as part of an inlined package, but are not themselves
 551          --  called. An accurate computation of just those subprograms that
 552          --  are needed requires that we perform a transitive closure over
 553          --  the call graph, starting from calls in the main program. Here
 554          --  we do one step of the inverse transitive closure, and reset
 555          --  the Is_Called flag on subprograms all of whose callers are not.
 556
 557          for Index in Inlined.First .. Inlined.Last loop
 558             S := Inlined.Table (Index).First_Succ;
 559
 560             if S /= No_Succ
 561               and then not Inlined.Table (Index).Main_Call
 562             then
 563                Set_Is_Called (Inlined.Table (Index).Name, False);
 564
 565                while S /= No_Succ loop
 566
 567                   if Is_Called
 568                     (Inlined.Table (Successors.Table (S).Subp).Name)
 569                    or else Inlined.Table (Successors.Table (S).Subp).Main_Call
 570                   then
 571                      Set_Is_Called (Inlined.Table (Index).Name);
 572                      exit;
 573                   end if;
 574
 575                   S := Successors.Table (S).Next;
 576                end loop;
 577             end if;
 578          end loop;
 579
 580          --  Now that the units are compiled, chain the subprograms within
 581          --  that are called and inlined. Produce list of inlined subprograms
 582          --  sorted in  topological order. Start with all subprograms that
 583          --  have no prerequisites, i.e. inlined subprograms that do not call
 584          --  other inlined subprograms.
 585
 586          for Index in Inlined.First .. Inlined.Last loop
 587
 588             if Is_Called (Inlined.Table (Index).Name)
 589               and then Inlined.Table (Index).Count = 0
 590               and then not Inlined.Table (Index).Listed
 591             then
 592                Add_Inlined_Subprogram (Index);
 593             end if;
 594          end loop;
 595
 596          --  Because Add_Inlined_Subprogram treats recursively nodes that have
 597          --  no prerequisites left, at the end of the loop all subprograms
 598          --  must have been listed. If there are any unlisted subprograms
 599          --  left, there must be some recursive chains that cannot be inlined.
 600
 601          for Index in Inlined.First .. Inlined.Last loop
 602             if Is_Called (Inlined.Table (Index).Name)
 603               and then Inlined.Table (Index).Count /= 0
 604               and then not Is_Predefined_File_Name
 605                 (Unit_File_Name
 606                   (Get_Source_Unit (Inlined.Table (Index).Name)))
 607             then
 608                Error_Msg_N
 609                  ("& cannot be inlined?", Inlined.Table (Index).Name);
 610                --  A warning on the first one might be sufficient.
 611             end if;
 612          end loop;
 613
 614          Pop_Scope;
 615       end if;
 616    end Analyze_Inlined_Bodies;
 617
 618    --------------------------------
 619    --  Check_Body_For_Inlining --
 620    --------------------------------
 621
 622    procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
 623       Bname : Unit_Name_Type;
 624       E     : Entity_Id;
 625       OK    : Boolean;
 626
 627    begin
 628       if Is_Compilation_Unit (P)
 629         and then not Is_Generic_Instance (P)
 630       then
 631          Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
 632          E := First_Entity (P);
 633
 634          while Present (E) loop
 635             if Has_Pragma_Inline (E) then
 636                if not Is_Loaded (Bname) then
 637                   Load_Needed_Body (N, OK);
 638
 639                   if not OK
 640                     and then Ineffective_Inline_Warnings
 641                   then
 642                      Error_Msg_Unit_1 := Bname;
 643                      Error_Msg_N
 644                        ("unable to inline subprograms defined in $?", P);
 645                      Error_Msg_N ("\body not found?", P);
 646                      return;
 647                   end if;
 648                end if;
 649
 650                return;
 651             end if;
 652
 653             Next_Entity (E);
 654          end loop;
 655       end if;
 656    end Check_Body_For_Inlining;
 657
 658    --------------------
 659    -- Cleanup_Scopes --
 660    --------------------
 661
 662    procedure Cleanup_Scopes is
 663       Elmt : Elmt_Id;
 664       Decl : Node_Id;
 665       Scop : Entity_Id;
 666
 667    begin
 668       Elmt := First_Elmt (To_Clean);
 669
 670       while Present (Elmt) loop
 671          Scop := Node (Elmt);
 672
 673          if Ekind (Scop) = E_Entry then
 674             Scop := Protected_Body_Subprogram (Scop);
 675          end if;
 676
 677          if Ekind (Scop) = E_Block then
 678             Decl := Parent (Block_Node (Scop));
 679
 680          else
 681             Decl := Unit_Declaration_Node (Scop);
 682
 683             if Nkind (Decl) = N_Subprogram_Declaration
 684               or else Nkind (Decl) = N_Task_Type_Declaration
 685               or else Nkind (Decl) = N_Subprogram_Body_Stub
 686             then
 687                Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
 688             end if;
 689          end if;
 690
 691          New_Scope (Scop);
 692          Expand_Cleanup_Actions (Decl);
 693          End_Scope;
 694
 695          Elmt := Next_Elmt (Elmt);
 696       end loop;
 697    end Cleanup_Scopes;
 698
 699    --------------------------
 700    -- Has_Initialized_Type --
 701    --------------------------
 702
 703    function Has_Initialized_Type (E : Entity_Id) return Boolean is
 704       E_Body : constant Node_Id := Get_Subprogram_Body (E);
 705       Decl   : Node_Id;
 706
 707    begin
 708       if No (E_Body) then        --  imported subprogram
 709          return False;
 710
 711       else
 712          Decl := First (Declarations (E_Body));
 713
 714          while Present (Decl) loop
 715
 716             if Nkind (Decl) = N_Full_Type_Declaration
 717               and then Present (Init_Proc (Defining_Identifier (Decl)))
 718             then
 719                return True;
 720             end if;
 721
 722             Next (Decl);
 723          end loop;
 724       end if;
 725
 726       return False;
 727    end Has_Initialized_Type;
 728
 729    ----------------
 730    -- Initialize --
 731    ----------------
 732
 733    procedure Initialize is
 734    begin
 735       Analyzing_Inlined_Bodies := False;
 736       Pending_Descriptor.Init;
 737       Pending_Instantiations.Init;
 738       Inlined_Bodies.Init;
 739       Successors.Init;
 740       Inlined.Init;
 741
 742       for J in Hash_Headers'Range loop
 743          Hash_Headers (J) := No_Subp;
 744       end loop;
 745    end Initialize;
 746
 747    ------------------------
 748    -- Instantiate_Bodies --
 749    ------------------------
 750
 751    --  Generic bodies contain all the non-local references, so an
 752    --  instantiation does not need any more context than Standard
 753    --  itself, even if the instantiation appears in an inner scope.
 754    --  Generic associations have verified that the contract model is
 755    --  satisfied, so that any error that may occur in the analysis of
 756    --  the body is an internal error.
 757
 758    procedure Instantiate_Bodies is
 759       J    : Int;
 760       Info : Pending_Body_Info;
 761
 762    begin
 763       if Serious_Errors_Detected = 0 then
 764
 765          Expander_Active :=  (Operating_Mode = Opt.Generate_Code);
 766          New_Scope (Standard_Standard);
 767          To_Clean := New_Elmt_List;
 768
 769          if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
 770             Start_Generic;
 771          end if;
 772
 773          --  A body instantiation may generate additional instantiations, so
 774          --  the following loop must scan to the end of a possibly expanding
 775          --  set (that's why we can't simply use a FOR loop here).
 776
 777          J := 0;
 778
 779          while J <= Pending_Instantiations.Last
 780            and then Serious_Errors_Detected = 0
 781          loop
 782
 783             Info := Pending_Instantiations.Table (J);
 784
 785             --  If the  instantiation node is absent, it has been removed
 786             --  as part of unreachable code.
 787
 788             if No (Info.Inst_Node) then
 789                null;
 790
 791             elsif Nkind (Info. Act_Decl) = N_Package_Declaration then
 792                Instantiate_Package_Body (Info);
 793                Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
 794
 795             else
 796                Instantiate_Subprogram_Body (Info);
 797             end if;
 798
 799             J := J + 1;
 800          end loop;
 801
 802          --  Reset the table of instantiations. Additional instantiations
 803          --  may be added through inlining, when additional bodies are
 804          --  analyzed.
 805
 806          Pending_Instantiations.Init;
 807
 808          --  We can now complete the cleanup actions of scopes that contain
 809          --  pending instantiations (skipped for generic units, since we
 810          --  never need any cleanups in generic units).
 811          --  pending instantiations.
 812
 813          if Expander_Active
 814            and then not Is_Generic_Unit (Main_Unit_Entity)
 815          then
 816             Cleanup_Scopes;
 817
 818             --  Also generate subprogram descriptors that were delayed
 819
 820             for J in Pending_Descriptor.First .. Pending_Descriptor.Last loop
 821                declare
 822                   Ent : constant Entity_Id := Pending_Descriptor.Table (J);
 823
 824                begin
 825                   if Is_Subprogram (Ent) then
 826                      Generate_Subprogram_Descriptor_For_Subprogram
 827                        (Get_Subprogram_Body (Ent), Ent);
 828
 829                   elsif Ekind (Ent) = E_Package then
 830                      Generate_Subprogram_Descriptor_For_Package
 831                        (Parent (Declaration_Node (Ent)), Ent);
 832
 833                   elsif Ekind (Ent) = E_Package_Body then
 834                      Generate_Subprogram_Descriptor_For_Package
 835                        (Declaration_Node (Ent), Ent);
 836                   end if;
 837                end;
 838             end loop;
 839
 840          elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
 841             End_Generic;
 842          end if;
 843
 844          Pop_Scope;
 845       end if;
 846    end Instantiate_Bodies;
 847
 848    ---------------
 849    -- Is_Nested --
 850    ---------------
 851
 852    function Is_Nested (E : Entity_Id) return Boolean is
 853       Scop : Entity_Id := Scope (E);
 854
 855    begin
 856       while Scop /= Standard_Standard loop
 857          if Ekind (Scop) in Subprogram_Kind then
 858             return True;
 859
 860          elsif Ekind (Scop) = E_Task_Type
 861            or else Ekind (Scop) = E_Entry
 862            or else Ekind (Scop) = E_Entry_Family then
 863             return True;
 864          end if;
 865
 866          Scop := Scope (Scop);
 867       end loop;
 868
 869       return False;
 870    end Is_Nested;
 871
 872    ----------
 873    -- Lock --
 874    ----------
 875
 876    procedure Lock is
 877    begin
 878       Pending_Instantiations.Locked := True;
 879       Inlined_Bodies.Locked := True;
 880       Successors.Locked := True;
 881       Inlined.Locked := True;
 882       Pending_Instantiations.Release;
 883       Inlined_Bodies.Release;
 884       Successors.Release;
 885       Inlined.Release;
 886    end Lock;
 887
 888    --------------------------
 889    -- Remove_Dead_Instance --
 890    --------------------------
 891
 892    procedure Remove_Dead_Instance (N : Node_Id) is
 893       J    : Int;
 894
 895    begin
 896       J := 0;
 897
 898       while J <= Pending_Instantiations.Last loop
 899
 900          if Pending_Instantiations.Table (J).Inst_Node = N then
 901             Pending_Instantiations.Table (J).Inst_Node := Empty;
 902             return;
 903          end if;
 904
 905          J := J + 1;
 906       end loop;
 907    end Remove_Dead_Instance;
 908
 909    ------------------------
 910    -- Scope_In_Main_Unit --
 911    ------------------------
 912
 913    function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is
 914       Comp : Node_Id;
 915       S    : Entity_Id := Scop;
 916       Ent  : Entity_Id := Cunit_Entity (Main_Unit);
 917
 918    begin
 919       --  The scope may be within the main unit, or it may be an ancestor
 920       --  of the main unit, if the main unit is a child unit. In both cases
 921       --  it makes no sense to process the body before the main unit. In
 922       --  the second case, this may lead to circularities if a parent body
 923       --  depends on a child spec, and we are analyzing the child.
 924
 925       while Scope (S) /= Standard_Standard
 926         and then not Is_Child_Unit (S)
 927       loop
 928          S := Scope (S);
 929       end loop;
 930
 931       Comp := Parent (S);
 932
 933       while Present (Comp)
 934         and then Nkind (Comp) /= N_Compilation_Unit
 935       loop
 936          Comp := Parent (Comp);
 937       end loop;
 938
 939       if Is_Child_Unit (Ent) then
 940
 941          while Present (Ent)
 942            and then Is_Child_Unit (Ent)
 943          loop
 944             if Scope (Ent) = S then
 945                return True;
 946             end if;
 947
 948             Ent := Scope (Ent);
 949          end loop;
 950       end if;
 951
 952       return
 953         Comp = Cunit (Main_Unit)
 954           or else Comp = Library_Unit (Cunit (Main_Unit));
 955    end Scope_In_Main_Unit;
 956
 957 end Inline;