From 38cbfe40a046b12a3d9bc56e6cf76d86c458ef39 Mon Sep 17 00:00:00 2001 From: Richard Kenner <kenner@gcc.gnu.org> Date: Tue, 2 Oct 2001 10:18:40 -0400 Subject: New Language: Ada From-SVN: r45955 --- gcc/ada/live.adb | 346 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 346 insertions(+) create mode 100644 gcc/ada/live.adb (limited to 'gcc/ada/live.adb') diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb new file mode 100644 index 00000000000..16627c2b5cd --- /dev/null +++ b/gcc/ada/live.adb @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- L I V E -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.4 $ +-- -- +-- 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. -- +-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +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; -- cgit v1.2.1