Geek Gadgets 1/ADE-1.bin/ade-dist/gnat-2.06-src.tgz/tar.out/fsf/gnat/ada/inline.adb

Text File | 1996-09-28 | 19KB | 545 lines

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               I N L I N E                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.4 $                              --
--                                                                          --
--        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
-- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Expander; use Expander;
with Lib;      use Lib;
with Output;   use Output;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Uname;    use Uname;

package body Inline is

   -----------------------
   -- Inline Processing --
   -----------------------

   --  For each call to an inlined subprogram, we make entries in a table
   --  that stores caller and callee, and indicates a prerequisite from
   --  one to the other. We also record the compilation unit that contains
   --  the callee. After analyzing the bodies of all such compilation units,
   --  we produce a list of subprograms in  topological order, for use by the
   --  back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for
   --  proper inlining the back-end must analyze the body of P2 before that of
   --  P1. The code below guarantees that the transitive closure of inlined
   --  subprograms called from the main compilation unit is made available to
   --  the code generator.

   Last_Inlined : Entity_Id := Empty;
   Last_No_Pred : Entity_Id := Empty;

   --  For each entry in the table we keep a list of successors in topological
   --  order, i.e. callers of the current subprogram.

   type Subp_Index is new Nat;
   No_Subp : constant Subp_Index := 0;

   --  The subprogram entities are hashed into the Inlined table.

   Num_Hash_Headers : constant := 512;

   Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
                                                          of Subp_Index;

   type Succ_Index is new Nat;
   No_Succ : constant Succ_Index := 0;

   type Succ_Info is record
      Subp : Subp_Index;
      Next : Succ_Index;
   end record;

   --  The following table stores list elements for the successor lists.
   --  These lists cannot be chained directly through entries in the Inlined
   --  table, because a given subprogram can appear in several such lists.

   package Successors is new Table (
      Table_Component_Type => Succ_Info,
      Table_Index_Type     => Succ_Index,
      Table_Low_Bound      => 1,
      Table_Initial        => 2000,
      Table_Increment      => 20,
      Table_Name           => "Successors");

   type Subp_Info is record
      Name        : Entity_Id  := Empty;
      First_Succ  : Succ_Index := No_Succ;
      Count       : Integer    := 0;
      Listed      : Boolean    := False;
      Main_Call  : Boolean    := False;
      Next        : Subp_Index := No_Subp;
      Next_Nopred : Subp_Index := No_Subp;
   end record;

   package Inlined is new Table (
      Table_Component_Type => Subp_Info,
      Table_Index_Type     => Subp_Index,
      Table_Low_Bound      => 1,
      Table_Initial        => 1000,
      Table_Increment      => 20,
      Table_Name           => "Inline_Table");

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean;
   --  Return True if Scop is in the main unit or its spec.

   procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
   --  Make two entries in Inlined table, for an inlined subprogram being
   --  called, and for the inlined subprogram that contains the call. If
   --  the call is in the main compilation unit, Caller is Empty.

   function Add_Subp (E : Entity_Id) return Subp_Index;
   --  Make entry in Inlined table for subprogram E, or return table index
   --  that already holds E.

   procedure New_No_Pred (Index : Subp_Index);
   --  Add subprogram to Inlined List once all of its predecessors have been
   --  placed on the list. Decrement the count of all its successors, and
   --  add them to list (recursively) if count drops to zero.

   ------------------------
   -- Instantiate_Bodies --
   ------------------------

   --  Generic bodies contain all the non-local references, so an
   --  instantiation does not need any more context than Standard
   --  itself, even if the instantiation appears in an inner scope.
   --  Generic associations have verified that the contract model is
   --  satisfied, so that any error that may occur in the analysis of
   --  the body is an internal error.

   procedure Instantiate_Bodies is
      J    : Int;
      Decl : Node_Id;
      Inst : Node_Id;

   begin
      if Errors_Detected = 0 then
         Expander_Active := True;
         New_Scope (Standard_Standard);

         --  A body instantiation may generate additional instantiations, so
         --  the following loop must scan to the end of a possibly expanding
         --  set (that's why we can't simply use a FOR loop here).

         J := 0;

         while J <= Pending_Instantiations.Last
           and then Errors_Detected = 0
         loop
            Decl := Pending_Instantiations.Table (J).Act_Decl;
            Inst := Pending_Instantiations.Table (J).Inst_Node;

            if Nkind (Decl) = N_Package_Declaration then
               Instantiate_Package_Body (Inst, Decl);
            else
               Instantiate_Subprogram_Body (Inst, Decl);
            end if;

            J := J + 1;
         end loop;

         --  Reset the table of instantiations. Additional instantiations
         --  may be added through inlining, when additional bodies are
         --  analyzed.

         Pending_Instantiations.Init;
         Pop_Scope;
      end if;
   end Instantiate_Bodies;

   ----------------------
   -- Add_Inlined_Body --
   ----------------------

   procedure Add_Inlined_Body (N : Node_Id; E : Entity_Id) is
      Pack : Entity_Id;
      Comp_Unit : Node_Id;

      function Must_Inline return Boolean;
      --  Inlining is only done if the call statement N is in the main unit,
      --  or within the body of another inlined subprogram.

      function Must_Inline return Boolean is
         Scop : Entity_Id := Current_Scope;
         Comp : Node_Id;

      begin
         while Scope (Scop) /= Standard_Standard
           and then not Is_Child_Unit (Scop)
         loop
            if Is_Overloadable (Scop)
              and then Is_Inlined (Scop)
            then
               Add_Call (E, Scop);
               return True;
            end if;

            Scop := Scope (Scop);
         end loop;

         --  Call is not within an inlined body. Check whether it is in
         --  main unit.

         Comp := Parent (Scop);

         while Nkind (Comp) /= N_Compilation_Unit loop
            Comp := Parent (Comp);
         end loop;

         if (Comp = Cunit (Main_Unit)
           or else Comp = Library_Unit (Cunit (Main_Unit)))
         then
            Add_Call (E);
            return True;
         else
            return False;
         end if;
      end Must_Inline;

   begin
      --  Find unit containing E, and add to list of inlined bodies if needed.
      --  If the body is already present, no need to load any other unit. This
      --  is the case for an initialization procedure, which appears in the
      --  package declaration that contains the type. It is also the case if
      --  the body has already been analyzed.

      if not Is_Abstract (E) then
         Pack := Scope (E);

         if Must_Inline
           and then Ekind (Pack) = E_Package
         then
            Set_Is_Called (E);
            Comp_Unit := Parent (Pack);

            if not Is_Inlined (Pack)
              and then not Has_Completion (E)
              and then not Scope_In_Main_Unit (Pack)
            then
               Set_Is_Inlined (Pack);
               Inlined_Bodies.Increment_Last;
               Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
            end if;
         end if;
      end if;
   end Add_Inlined_Body;

   ----------------------------
   -- Analyze_Inlined_Bodies --
   ----------------------------

   procedure Analyze_Inlined_Bodies is
      Comp_Unit : Node_Id;
      J         : Int;
      Pack      : Entity_Id;
      S         : Succ_Index;
   begin
      J := 0;

      if Errors_Detected = 0 then
         New_Scope (Standard_Standard);

         while J <= Inlined_Bodies.Last
           and then Errors_Detected = 0
         loop
            Pack := Inlined_Bodies.Table (J);

            while Present (Pack)
              and then Scope (Pack) /= Standard_Standard
              and then not Is_Child_Unit (Pack)
            loop
               Pack := Scope (Pack);
            end loop;

            Comp_Unit := Parent (Pack);

            while Present (Comp_Unit)
              and then Nkind (Comp_Unit) /= N_Compilation_Unit
            loop
               Comp_Unit := Parent (Comp_Unit);
            end loop;

            if Present (Comp_Unit)
              and then Comp_Unit /= Cunit (Main_Unit)
             and then Body_Required (Comp_Unit)
              and then not
                Is_Loaded (Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit))))
            then
               Load_Needed_Body (Comp_Unit);
            end if;

            J := J + 1;
         end loop;

         --  The analysis of required bodies may have produced additional
         --  generic instantiations. To obtain further inlining, we perform
         --  another round of generic body instantiations. Establishing a
         --  fully recursive loop between inlining and generic instantiations
         --  is unlikely to yield more than this one additional pass.

         Instantiate_Bodies;

         --  The list of inlined subprograms is an overestimate, because
         --  it includes inlined functions called from functions that are
         --  compiled as part of an inlined package, but are not themselves
         --  called. An accurate computation of just those subprograms that
         --  are needed requires that we perform a transitive closure over
         --  the call graph, starting from calls in the main program. Here
         --  we do one step of the inverse transitive closure, and reset
         --  the Is_Called flag on subprograms all of whose callers are not.

         for Index in Inlined.First .. Inlined.Last loop
            S := Inlined.Table (Index).First_Succ;

            if S /= No_Succ
              and then not Inlined.Table (Index).Main_Call
            then
               Set_Is_Called (Inlined.Table (Index).Name, False);

               while S /= No_Succ loop

                  if Is_Called
                    (Inlined.Table (Successors.Table (S).Subp).Name)
                   or else Inlined.Table (Successors.Table (S).Subp).Main_Call
                  then
                     Set_Is_Called (Inlined.Table (Index).Name);
                     exit;
                  end if;

                  S := Successors.Table (S).Next;
               end loop;
            end if;
         end loop;

         --  Now that the units are compiled, chain the subprograms within
         --  that are called and inlined. Produce list of inlined subprograms
         --  sorted in  topological order. Start with all subprograms that
         --  have no prerequisites, i.e. inlined subprograms that do not call
         --  other inlined subprograms.

         for Index in Inlined.First .. Inlined.Last loop

            if Is_Called (Inlined.Table (Index).Name)
              and then Inlined.Table (Index).Count = 0
              and then not Inlined.Table (Index).Listed
            then
               New_No_Pred (Index);
            end if;
         end loop;

         --  Because New_No_Pred treats recursively nodes that have no
         --  prerequisites left, at the end of the loop all subprograms
         --  must have been listed. If there are any unlisted subprograms
         --  left, there must be some recursive chains that cannot be inlined.

         for Index in Inlined.First .. Inlined.Last loop
            if Is_Called (Inlined.Table (Index).Name)
              and then Inlined.Table (Index).Count /= 0
            then
               Error_Msg_N
                 ("cannot be inlined?", Inlined.Table (Index).Name);
               --  A warning on the first one might be sufficient.
            end if;
         end loop;

         Pop_Scope;
      end if;
   end Analyze_Inlined_Bodies;

   -------------------------
   --  Scope_In_Main_Unit --
   -------------------------

   function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is
      Comp : Node_Id;
      S : Entity_Id := Scop;
   begin
      while Scope (S) /= Standard_Standard
        and then not Is_Child_Unit (S)
      loop
         S := Scope (S);
      end loop;

      Comp := Parent (S);

      while Present (Comp)
        and then Nkind (Comp) /= N_Compilation_Unit
      loop
         Comp := Parent (Comp);
      end loop;

      return (Comp = Cunit (Main_Unit)
           or else Comp = Library_Unit (Cunit (Main_Unit)));
   end Scope_In_Main_Unit;

   ---------------
   --  Add_Call --
   ---------------

   procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
      P1 : Subp_Index := Add_Subp (Called);
      P2 : Subp_Index;
      J  : Succ_Index;
   begin
      if Present (Caller) then
         P2 := Add_Subp (Caller);

         --  Add P2 to the list of successors of P1, if not already there.
         --  Note that P2 may contain more than one call to P1, and only
         --  one needs to be recorded.

         J := Inlined.Table (P1).First_Succ;

         while J /= No_Succ loop

            if Successors.Table (J).Subp = P2 then
               return;
            end if;

            J := Successors.Table (J).Next;
         end loop;

         --  On exit, make a successor entry for P2.

         Successors.Increment_Last;
         Successors.Table (Successors.Last).Subp := P2;
         Successors.Table (Successors.Last).Next :=
                             Inlined.Table (P1).First_Succ;
         Inlined.Table (P1).First_Succ := Successors.Last;

         Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1;

      else
         Inlined.Table (P1).Main_Call := True;
      end if;
   end Add_Call;

   ---------------
   --  Add_Subp --
   ---------------

   function Add_Subp (E : Entity_Id) return Subp_Index is
      Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
      J     : Subp_Index;

      procedure New_Entry;
      --  Initialize entry in Inlined table.

      procedure New_Entry is
      begin
         Inlined.Increment_Last;
         Inlined.Table (Inlined.Last).Name        := E;
         Inlined.Table (Inlined.Last).First_Succ  := No_Succ;
         Inlined.Table (Inlined.Last).Count       := 0;
         Inlined.Table (Inlined.Last).Listed      := False;
         Inlined.Table (Inlined.Last).Next        := No_Subp;
         Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
      end New_Entry;

   begin
      if Hash_Headers (Index) = No_Subp then
         New_Entry;
         Hash_Headers (Index) := Inlined.Last;
         return Inlined.Last;

      else
         J := Hash_Headers (Index);

         while J /= No_Subp loop

            if Inlined.Table (J).Name = E then
               return J;
            else
               Index := J;
               J := Inlined.Table (J).Next;
            end if;
         end loop;

         --  On exit, subprogram was not found. Enter in table. Index is
         --  the current last entry on the hash chain.

         New_Entry;
         Inlined.Table (Index).Next := Inlined.Last;
         return Inlined.Last;
      end if;
   end Add_Subp;

   -----------------
   -- New_No_Pred --
   -----------------

   procedure New_No_Pred (Index : Subp_Index) is
      E    : constant Entity_Id := Inlined.Table (Index).Name;
      Succ : Succ_Index;
      Subp : Subp_Index;

   begin
      --  Insert the current subprogram in the  list of inlined subprograms.

      if not Scope_In_Main_Unit (Scope (E)) then
         if No (Last_Inlined) then
            Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
         else
            Set_Next_Inlined_Subprogram (Last_Inlined, E);
         end if;
      end if;

      Last_Inlined := E;
      Inlined.Table (Index).Listed := True;

      --  Write_Entity_Info (E, "");
      --  Write_Eol;

      Succ := Inlined.Table (Index).First_Succ;

      while Succ /= No_Succ loop
         Subp := Successors.Table (Succ).Subp;
         Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;

         if Inlined.Table (Subp).Count = 0 then
            New_No_Pred (Subp);
         end if;

         Succ := Successors.Table (Succ).Next;
      end loop;

   end New_No_Pred;

begin
   for J in Hash_Headers'Range loop
      Hash_Headers (J) := No_Subp;
   end loop;
end Inline;