Subversion Repositories openrisc_2011-10-31

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                 L I V E                                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2000-2007, Free Software Foundation, Inc.         --
--                                                                          --
-- 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 3,  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 COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Atree;    use Atree;
with Einfo;    use Einfo;
with Lib;      use Lib;
with Nlists;   use Nlists;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Types;    use Types;
 
package body Live is
 
   --  Name_Set
 
   --  The Name_Set type is used to store the temporary mark bits
   --  used by the garbage collection of entities. Using a separate
   --  array prevents using up any valuable per-node space and possibly
   --  results in better locality and cache usage.
 
   type Name_Set is array (Node_Id range <>) of Boolean;
   pragma Pack (Name_Set);
 
   function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
   pragma Inline (Marked);
 
   procedure Set_Marked
     (Marks : in out Name_Set;
      Name  : Node_Id;
      Mark  : Boolean := True);
   pragma Inline (Set_Marked);
 
   --  Algorithm
 
   --  The problem of finding live entities is solved in two steps:
 
   procedure Mark (Root : Node_Id; Marks : out Name_Set);
   --  Mark all live entities in Root as Marked
 
   procedure Sweep (Root : Node_Id; Marks : Name_Set);
   --  For all unmarked entities in Root set Is_Eliminated to true
 
   --  The Mark phase is split into two phases:
 
   procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
   --  For all subprograms, reset Is_Public flag if a pragma Eliminate
   --  applies to the entity, and set the Marked flag to Is_Public
 
   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
   --  Traverse the tree skipping any unmarked subprogram bodies.
   --  All visited entities are marked, as well as entities denoted
   --  by a visited identifier or operator. When an entity is first
   --  marked it is traced as well.
 
   --  Local functions
 
   function Body_Of (E : Entity_Id) return Node_Id;
   --  Returns subprogram body corresponding to entity E
 
   function Spec_Of (N : Node_Id) return Entity_Id;
   --  Given a subprogram body N, return defining identifier of its declaration
 
   --  ??? the body of this package contains no comments at all, this
   --  should be fixed!
 
   -------------
   -- Body_Of --
   -------------
 
   function Body_Of (E : Entity_Id) return Node_Id is
      Decl   : constant Node_Id   := Unit_Declaration_Node (E);
      Kind   : constant Node_Kind := Nkind (Decl);
      Result : Node_Id;
 
   begin
      if Kind = N_Subprogram_Body then
         Result := Decl;
 
      elsif Kind /= N_Subprogram_Declaration
        and  Kind /= N_Subprogram_Body_Stub
      then
         Result := Empty;
 
      else
         Result := Corresponding_Body (Decl);
 
         if Result /= Empty then
            Result := Unit_Declaration_Node (Result);
         end if;
      end if;
 
      return Result;
   end Body_Of;
 
   ------------------------------
   -- Collect_Garbage_Entities --
   ------------------------------
 
   procedure Collect_Garbage_Entities is
      Root  : constant Node_Id := Cunit (Main_Unit);
      Marks : Name_Set (0 .. Last_Node_Id);
 
   begin
      Mark (Root, Marks);
      Sweep (Root, Marks);
   end Collect_Garbage_Entities;
 
   -----------------
   -- Init_Marked --
   -----------------
 
   procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
 
      function Process (N : Node_Id) return Traverse_Result;
      procedure Traverse is new Traverse_Proc (Process);
 
      function Process (N : Node_Id) return Traverse_Result is
      begin
         case Nkind (N) is
            when N_Entity'Range =>
               if Is_Eliminated (N) then
                  Set_Is_Public (N, False);
               end if;
 
               Set_Marked (Marks, N, Is_Public (N));
 
            when N_Subprogram_Body =>
               Traverse (Spec_Of (N));
 
            when N_Package_Body_Stub =>
               if Present (Library_Unit (N)) then
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
               end if;
 
            when N_Package_Body =>
               declare
                  Elmt : Node_Id := First (Declarations (N));
               begin
                  while Present (Elmt) loop
                     Traverse (Elmt);
                     Next (Elmt);
                  end loop;
               end;
 
            when others =>
               null;
         end case;
 
         return OK;
      end Process;
 
   --  Start of processing for Init_Marked
 
   begin
      Marks := (others => False);
      Traverse (Root);
   end Init_Marked;
 
   ----------
   -- Mark --
   ----------
 
   procedure Mark (Root : Node_Id; Marks : out Name_Set) is
   begin
      Init_Marked (Root, Marks);
      Trace_Marked (Root, Marks);
   end Mark;
 
   ------------
   -- Marked --
   ------------
 
   function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
   begin
      return Marks (Name);
   end Marked;
 
   ----------------
   -- Set_Marked --
   ----------------
 
   procedure Set_Marked
     (Marks : in out Name_Set;
      Name  : Node_Id;
      Mark  : Boolean := True)
   is
   begin
      Marks (Name) := Mark;
   end Set_Marked;
 
   -------------
   -- Spec_Of --
   -------------
 
   function Spec_Of (N : Node_Id) return Entity_Id is
   begin
      if Acts_As_Spec (N) then
         return Defining_Entity (N);
      else
         return Corresponding_Spec (N);
      end if;
   end Spec_Of;
 
   -----------
   -- Sweep --
   -----------
 
   procedure Sweep (Root : Node_Id; Marks : Name_Set) is
 
      function Process (N : Node_Id) return Traverse_Result;
      procedure Traverse is new Traverse_Proc (Process);
 
      function Process (N : Node_Id) return Traverse_Result is
      begin
         case Nkind (N) is
            when N_Entity'Range =>
               Set_Is_Eliminated (N, not Marked (Marks, N));
 
            when N_Subprogram_Body =>
               Traverse (Spec_Of (N));
 
            when N_Package_Body_Stub =>
               if Present (Library_Unit (N)) then
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
               end if;
 
            when N_Package_Body =>
               declare
                  Elmt : Node_Id := First (Declarations (N));
               begin
                  while Present (Elmt) loop
                     Traverse (Elmt);
                     Next (Elmt);
                  end loop;
               end;
 
            when others =>
               null;
         end case;
         return OK;
      end Process;
 
   begin
      Traverse (Root);
   end Sweep;
 
   ------------------
   -- Trace_Marked --
   ------------------
 
   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
 
      function  Process (N : Node_Id) return Traverse_Result;
      procedure Process (N : Node_Id);
      procedure Traverse is new Traverse_Proc (Process);
 
      procedure Process (N : Node_Id) is
         Result : Traverse_Result;
         pragma Warnings (Off, Result);
 
      begin
         Result := Process (N);
      end Process;
 
      function Process (N : Node_Id) return Traverse_Result is
         Result : Traverse_Result := OK;
         B      : Node_Id;
         E      : Entity_Id;
 
      begin
         case Nkind (N) is
            when N_Pragma | N_Generic_Declaration'Range |
                 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
               Result := Skip;
 
            when N_Subprogram_Body =>
               if not Marked (Marks, Spec_Of (N)) then
                  Result := Skip;
               end if;
 
            when N_Package_Body_Stub =>
               if Present (Library_Unit (N)) then
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
               end if;
 
            when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
               E := Entity (N);
 
               if E /= Empty and then not Marked (Marks, E) then
                  Process (E);
 
                  if Is_Subprogram (E) then
                     B := Body_Of (E);
 
                     if B /= Empty then
                        Traverse (B);
                     end if;
                  end if;
               end if;
 
            when N_Entity'Range =>
               if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
                  if Present (Discriminant_Checking_Func (N)) then
                     Process (Discriminant_Checking_Func (N));
                  end if;
               end if;
 
               Set_Marked (Marks, N);
 
            when others =>
               null;
         end case;
 
         return Result;
      end Process;
 
   --  Start of processing for Trace_Marked
 
   begin
      Traverse (Root);
   end Trace_Marked;
 
end Live;