1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2007, 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 3, 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree; use Atree;
27 with Einfo; use Einfo;
29 with Nlists; use Nlists;
30 with Sem_Util; use Sem_Util;
31 with Sinfo; use Sinfo;
32 with Types; use Types;
38 -- The Name_Set type is used to store the temporary mark bits
39 -- used by the garbage collection of entities. Using a separate
40 -- array prevents using up any valuable per-node space and possibly
41 -- results in better locality and cache usage.
43 type Name_Set is array (Node_Id range <>) of Boolean;
44 pragma Pack (Name_Set);
46 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
47 pragma Inline (Marked);
50 (Marks : in out Name_Set;
52 Mark : Boolean := True);
53 pragma Inline (Set_Marked);
57 -- The problem of finding live entities is solved in two steps:
59 procedure Mark (Root : Node_Id; Marks : out Name_Set);
60 -- Mark all live entities in Root as Marked
62 procedure Sweep (Root : Node_Id; Marks : Name_Set);
63 -- For all unmarked entities in Root set Is_Eliminated to true
65 -- The Mark phase is split into two phases:
67 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
68 -- For all subprograms, reset Is_Public flag if a pragma Eliminate
69 -- applies to the entity, and set the Marked flag to Is_Public
71 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
72 -- Traverse the tree skipping any unmarked subprogram bodies.
73 -- All visited entities are marked, as well as entities denoted
74 -- by a visited identifier or operator. When an entity is first
75 -- marked it is traced as well.
79 function Body_Of (E : Entity_Id) return Node_Id;
80 -- Returns subprogram body corresponding to entity E
82 function Spec_Of (N : Node_Id) return Entity_Id;
83 -- Given a subprogram body N, return defining identifier of its declaration
85 -- ??? the body of this package contains no comments at all, this
92 function Body_Of (E : Entity_Id) return Node_Id is
93 Decl : constant Node_Id := Unit_Declaration_Node (E);
94 Kind : constant Node_Kind := Nkind (Decl);
98 if Kind = N_Subprogram_Body then
101 elsif Kind /= N_Subprogram_Declaration
102 and Kind /= N_Subprogram_Body_Stub
107 Result := Corresponding_Body (Decl);
109 if Result /= Empty then
110 Result := Unit_Declaration_Node (Result);
117 ------------------------------
118 -- Collect_Garbage_Entities --
119 ------------------------------
121 procedure Collect_Garbage_Entities is
122 Root : constant Node_Id := Cunit (Main_Unit);
123 Marks : Name_Set (0 .. Last_Node_Id);
128 end Collect_Garbage_Entities;
134 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
136 function Process (N : Node_Id) return Traverse_Result;
137 procedure Traverse is new Traverse_Proc (Process);
139 function Process (N : Node_Id) return Traverse_Result is
142 when N_Entity'Range =>
143 if Is_Eliminated (N) then
144 Set_Is_Public (N, False);
147 Set_Marked (Marks, N, Is_Public (N));
149 when N_Subprogram_Body =>
150 Traverse (Spec_Of (N));
152 when N_Package_Body_Stub =>
153 if Present (Library_Unit (N)) then
154 Traverse (Proper_Body (Unit (Library_Unit (N))));
157 when N_Package_Body =>
159 Elmt : Node_Id := First (Declarations (N));
161 while Present (Elmt) loop
174 -- Start of processing for Init_Marked
177 Marks := (others => False);
185 procedure Mark (Root : Node_Id; Marks : out Name_Set) is
187 Init_Marked (Root, Marks);
188 Trace_Marked (Root, Marks);
195 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
205 (Marks : in out Name_Set;
207 Mark : Boolean := True)
210 Marks (Name) := Mark;
217 function Spec_Of (N : Node_Id) return Entity_Id is
219 if Acts_As_Spec (N) then
220 return Defining_Entity (N);
222 return Corresponding_Spec (N);
230 procedure Sweep (Root : Node_Id; Marks : Name_Set) is
232 function Process (N : Node_Id) return Traverse_Result;
233 procedure Traverse is new Traverse_Proc (Process);
235 function Process (N : Node_Id) return Traverse_Result is
238 when N_Entity'Range =>
239 Set_Is_Eliminated (N, not Marked (Marks, N));
241 when N_Subprogram_Body =>
242 Traverse (Spec_Of (N));
244 when N_Package_Body_Stub =>
245 if Present (Library_Unit (N)) then
246 Traverse (Proper_Body (Unit (Library_Unit (N))));
249 when N_Package_Body =>
251 Elmt : Node_Id := First (Declarations (N));
253 while Present (Elmt) loop
273 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
275 function Process (N : Node_Id) return Traverse_Result;
276 procedure Process (N : Node_Id);
277 procedure Traverse is new Traverse_Proc (Process);
279 procedure Process (N : Node_Id) is
280 Result : Traverse_Result;
281 pragma Warnings (Off, Result);
284 Result := Process (N);
287 function Process (N : Node_Id) return Traverse_Result is
288 Result : Traverse_Result := OK;
294 when N_Pragma | N_Generic_Declaration'Range |
295 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
298 when N_Subprogram_Body =>
299 if not Marked (Marks, Spec_Of (N)) then
303 when N_Package_Body_Stub =>
304 if Present (Library_Unit (N)) then
305 Traverse (Proper_Body (Unit (Library_Unit (N))));
308 when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
311 if E /= Empty and then not Marked (Marks, E) then
314 if Is_Subprogram (E) then
323 when N_Entity'Range =>
324 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
325 if Present (Discriminant_Checking_Func (N)) then
326 Process (Discriminant_Checking_Func (N));
330 Set_Marked (Marks, N);
339 -- Start of processing for Trace_Marked