1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2002 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree; use Atree;
28 with Einfo; use Einfo;
30 with Nlists; use Nlists;
31 with Sem_Util; use Sem_Util;
32 with Sinfo; use Sinfo;
33 with Types; use Types;
39 -- The Name_Set type is used to store the temporary mark bits
40 -- used by the garbage collection of entities. Using a separate
41 -- array prevents using up any valuable per-node space and possibly
42 -- results in better locality and cache usage.
44 type Name_Set is array (Node_Id range <>) of Boolean;
45 pragma Pack (Name_Set);
47 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
48 pragma Inline (Marked);
51 (Marks : in out Name_Set;
53 Mark : Boolean := True);
54 pragma Inline (Set_Marked);
58 -- The problem of finding live entities is solved in two steps:
60 procedure Mark (Root : Node_Id; Marks : out Name_Set);
61 -- Mark all live entities in Root as Marked.
63 procedure Sweep (Root : Node_Id; Marks : Name_Set);
64 -- For all unmarked entities in Root set Is_Eliminated to true
66 -- The Mark phase is split into two phases:
68 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
69 -- For all subprograms, reset Is_Public flag if a pragma Eliminate
70 -- applies to the entity, and set the Marked flag to Is_Public
72 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
73 -- Traverse the tree skipping any unmarked subprogram bodies.
74 -- All visited entities are marked, as well as entities denoted
75 -- by a visited identifier or operator. When an entity is first
76 -- marked it is traced as well.
80 function Body_Of (E : Entity_Id) return Node_Id;
81 -- Returns subprogram body corresponding to entity E
83 function Spec_Of (N : Node_Id) return Entity_Id;
84 -- Given a subprogram body N, return defining identifier of its declaration
86 -- ??? the body of this package contains no comments at all, this
93 function Body_Of (E : Entity_Id) return Node_Id is
94 Decl : constant Node_Id := Unit_Declaration_Node (E);
95 Kind : constant Node_Kind := Nkind (Decl);
99 if Kind = N_Subprogram_Body then
102 elsif Kind /= N_Subprogram_Declaration
103 and Kind /= N_Subprogram_Body_Stub
108 Result := Corresponding_Body (Decl);
110 if Result /= Empty then
111 Result := Unit_Declaration_Node (Result);
118 ------------------------------
119 -- Collect_Garbage_Entities --
120 ------------------------------
122 procedure Collect_Garbage_Entities is
123 Root : constant Node_Id := Cunit (Main_Unit);
124 Marks : Name_Set (0 .. Last_Node_Id);
129 end Collect_Garbage_Entities;
135 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
137 function Process (N : Node_Id) return Traverse_Result;
138 procedure Traverse is new Traverse_Proc (Process);
140 function Process (N : Node_Id) return Traverse_Result is
143 when N_Entity'Range =>
144 if Is_Eliminated (N) then
145 Set_Is_Public (N, False);
148 Set_Marked (Marks, N, Is_Public (N));
150 when N_Subprogram_Body =>
151 Traverse (Spec_Of (N));
153 when N_Package_Body_Stub =>
154 if Present (Library_Unit (N)) then
155 Traverse (Proper_Body (Unit (Library_Unit (N))));
158 when N_Package_Body =>
160 Elmt : Node_Id := First (Declarations (N));
162 while Present (Elmt) loop
175 -- Start of processing for Init_Marked
178 Marks := (others => False);
186 procedure Mark (Root : Node_Id; Marks : out Name_Set) is
188 Init_Marked (Root, Marks);
189 Trace_Marked (Root, Marks);
196 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
206 (Marks : in out Name_Set;
208 Mark : Boolean := True)
211 Marks (Name) := Mark;
218 function Spec_Of (N : Node_Id) return Entity_Id is
220 if Acts_As_Spec (N) then
221 return Defining_Entity (N);
223 return Corresponding_Spec (N);
231 procedure Sweep (Root : Node_Id; Marks : Name_Set) is
233 function Process (N : Node_Id) return Traverse_Result;
234 procedure Traverse is new Traverse_Proc (Process);
236 function Process (N : Node_Id) return Traverse_Result is
239 when N_Entity'Range =>
240 Set_Is_Eliminated (N, not Marked (Marks, N));
242 when N_Subprogram_Body =>
243 Traverse (Spec_Of (N));
245 when N_Package_Body_Stub =>
246 if Present (Library_Unit (N)) then
247 Traverse (Proper_Body (Unit (Library_Unit (N))));
250 when N_Package_Body =>
252 Elmt : Node_Id := First (Declarations (N));
254 while Present (Elmt) loop
274 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
276 function Process (N : Node_Id) return Traverse_Result;
277 procedure Process (N : Node_Id);
278 procedure Traverse is new Traverse_Proc (Process);
280 procedure Process (N : Node_Id) is
281 Result : Traverse_Result;
282 pragma Warnings (Off, Result);
285 Result := Process (N);
288 function Process (N : Node_Id) return Traverse_Result is
289 Result : Traverse_Result := OK;
295 when N_Pragma | N_Generic_Declaration'Range |
296 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
299 when N_Subprogram_Body =>
300 if not Marked (Marks, Spec_Of (N)) then
304 when N_Package_Body_Stub =>
305 if Present (Library_Unit (N)) then
306 Traverse (Proper_Body (Unit (Library_Unit (N))));
309 when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
312 if E /= Empty and then not Marked (Marks, E) then
315 if Is_Subprogram (E) then
324 when N_Entity'Range =>
325 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
326 if Present (Discriminant_Checking_Func (N)) then
327 Process (Discriminant_Checking_Func (N));
331 Set_Marked (Marks, N);
340 -- Start of processing for Trace_Marked