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;