path: root/gcc/ada/live.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                 L I V E                                  --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2000-2011, 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_Aux;  use Sem_Aux;
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;