------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- L I V E -- -- -- -- B o d y -- -- -- -- Copyright (C) 2000-2002 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 : 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;