aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.0/gcc/ada/live.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.0/gcc/ada/live.adb')
-rw-r--r--gcc-4.4.0/gcc/ada/live.adb345
1 files changed, 345 insertions, 0 deletions
diff --git a/gcc-4.4.0/gcc/ada/live.adb b/gcc-4.4.0/gcc/ada/live.adb
new file mode 100644
index 000000000..eaa52020b
--- /dev/null
+++ b/gcc-4.4.0/gcc/ada/live.adb
@@ -0,0 +1,345 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;