+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- L I V E --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 2000-2001 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 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, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- 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 : Node_Id := Unit_Declaration_Node (E);
- Result : Node_Id;
- Kind : Node_Kind := Nkind (Decl);
-
- 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;
- 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;
projects / msp430-gcc.git / blobdiff