File : live.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I V E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
10 -- --
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. --
20 -- --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
23 -- --
24 ------------------------------------------------------------------------------
25
26 with Atree; use Atree;
27 with Einfo; use Einfo;
28 with Lib; use Lib;
29 with Nlists; use Nlists;
30 with Sem_Aux; use Sem_Aux;
31 with Sem_Util; use Sem_Util;
32 with Sinfo; use Sinfo;
33 with Types; use Types;
34
35 package body Live is
36
37 -- Name_Set
38
39 -- The Name_Set type is used to store the temporary mark bits used by the
40 -- garbage collection of entities. Using a separate array prevents using up
41 -- any valuable per-node space and possibly results in better locality and
42 -- cache usage.
43
44 type Name_Set is array (Node_Id range <>) of Boolean;
45 pragma Pack (Name_Set);
46
47 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
48 pragma Inline (Marked);
49
50 procedure Set_Marked
51 (Marks : in out Name_Set;
52 Name : Node_Id;
53 Mark : Boolean := True);
54 pragma Inline (Set_Marked);
55
56 -- Algorithm
57
58 -- The problem of finding live entities is solved in two steps:
59
60 procedure Mark (Root : Node_Id; Marks : out Name_Set);
61 -- Mark all live entities in Root as Marked
62
63 procedure Sweep (Root : Node_Id; Marks : Name_Set);
64 -- For all unmarked entities in Root set Is_Eliminated to true
65
66 -- The Mark phase is split into two phases:
67
68 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
69 -- For all subprograms, reset Is_Public flag if a pragma Eliminate applies
70 -- to the entity, and set the Marked flag to Is_Public.
71
72 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
73 -- Traverse the tree skipping any unmarked subprogram bodies. All visited
74 -- entities are marked, as well as entities denoted by a visited identifier
75 -- or operator. When an entity is first marked it is traced as well.
76
77 -- Local functions
78
79 function Body_Of (E : Entity_Id) return Node_Id;
80 -- Returns subprogram body corresponding to entity E
81
82 function Spec_Of (N : Node_Id) return Entity_Id;
83 -- Given a subprogram body N, return defining identifier of its declaration
84
85 -- ??? the body of this package contains no comments at all, this
86 -- should be fixed.
87
88 -------------
89 -- Body_Of --
90 -------------
91
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);
95 Result : Node_Id;
96
97 begin
98 if Kind = N_Subprogram_Body then
99 Result := Decl;
100
101 elsif Kind /= N_Subprogram_Declaration
102 and Kind /= N_Subprogram_Body_Stub
103 then
104 Result := Empty;
105
106 else
107 Result := Corresponding_Body (Decl);
108
109 if Result /= Empty then
110 Result := Unit_Declaration_Node (Result);
111 end if;
112 end if;
113
114 return Result;
115 end Body_Of;
116
117 ------------------------------
118 -- Collect_Garbage_Entities --
119 ------------------------------
120
121 procedure Collect_Garbage_Entities is
122 Root : constant Node_Id := Cunit (Main_Unit);
123 Marks : Name_Set (0 .. Last_Node_Id);
124
125 begin
126 Mark (Root, Marks);
127 Sweep (Root, Marks);
128 end Collect_Garbage_Entities;
129
130 -----------------
131 -- Init_Marked --
132 -----------------
133
134 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
135
136 function Process (N : Node_Id) return Traverse_Result;
137 procedure Traverse is new Traverse_Proc (Process);
138
139 -------------
140 -- Process --
141 -------------
142
143 function Process (N : Node_Id) return Traverse_Result is
144 begin
145 case Nkind (N) is
146 when N_Entity'Range =>
147 if Is_Eliminated (N) then
148 Set_Is_Public (N, False);
149 end if;
150
151 Set_Marked (Marks, N, Is_Public (N));
152
153 when N_Subprogram_Body =>
154 Traverse (Spec_Of (N));
155
156 when N_Package_Body_Stub =>
157 if Present (Library_Unit (N)) then
158 Traverse (Proper_Body (Unit (Library_Unit (N))));
159 end if;
160
161 when N_Package_Body =>
162 declare
163 Elmt : Node_Id := First (Declarations (N));
164 begin
165 while Present (Elmt) loop
166 Traverse (Elmt);
167 Next (Elmt);
168 end loop;
169 end;
170
171 when others =>
172 null;
173 end case;
174
175 return OK;
176 end Process;
177
178 -- Start of processing for Init_Marked
179
180 begin
181 Marks := (others => False);
182 Traverse (Root);
183 end Init_Marked;
184
185 ----------
186 -- Mark --
187 ----------
188
189 procedure Mark (Root : Node_Id; Marks : out Name_Set) is
190 begin
191 Init_Marked (Root, Marks);
192 Trace_Marked (Root, Marks);
193 end Mark;
194
195 ------------
196 -- Marked --
197 ------------
198
199 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
200 begin
201 return Marks (Name);
202 end Marked;
203
204 ----------------
205 -- Set_Marked --
206 ----------------
207
208 procedure Set_Marked
209 (Marks : in out Name_Set;
210 Name : Node_Id;
211 Mark : Boolean := True)
212 is
213 begin
214 Marks (Name) := Mark;
215 end Set_Marked;
216
217 -------------
218 -- Spec_Of --
219 -------------
220
221 function Spec_Of (N : Node_Id) return Entity_Id is
222 begin
223 if Acts_As_Spec (N) then
224 return Defining_Entity (N);
225 else
226 return Corresponding_Spec (N);
227 end if;
228 end Spec_Of;
229
230 -----------
231 -- Sweep --
232 -----------
233
234 procedure Sweep (Root : Node_Id; Marks : Name_Set) is
235
236 function Process (N : Node_Id) return Traverse_Result;
237 procedure Traverse is new Traverse_Proc (Process);
238
239 -------------
240 -- Process --
241 -------------
242
243 function Process (N : Node_Id) return Traverse_Result is
244 begin
245 case Nkind (N) is
246 when N_Entity'Range =>
247 Set_Is_Eliminated (N, not Marked (Marks, N));
248
249 when N_Subprogram_Body =>
250 Traverse (Spec_Of (N));
251
252 when N_Package_Body_Stub =>
253 if Present (Library_Unit (N)) then
254 Traverse (Proper_Body (Unit (Library_Unit (N))));
255 end if;
256
257 when N_Package_Body =>
258 declare
259 Elmt : Node_Id := First (Declarations (N));
260 begin
261 while Present (Elmt) loop
262 Traverse (Elmt);
263 Next (Elmt);
264 end loop;
265 end;
266
267 when others =>
268 null;
269 end case;
270 return OK;
271 end Process;
272
273 -- Start of processing for Sweep
274
275 begin
276 Traverse (Root);
277 end Sweep;
278
279 ------------------
280 -- Trace_Marked --
281 ------------------
282
283 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
284
285 function Process (N : Node_Id) return Traverse_Result;
286 procedure Process (N : Node_Id);
287 procedure Traverse is new Traverse_Proc (Process);
288
289 -------------
290 -- Process --
291 -------------
292
293 procedure Process (N : Node_Id) is
294 Result : Traverse_Result;
295 pragma Warnings (Off, Result);
296
297 begin
298 Result := Process (N);
299 end Process;
300
301 function Process (N : Node_Id) return Traverse_Result is
302 Result : Traverse_Result := OK;
303 B : Node_Id;
304 E : Entity_Id;
305
306 begin
307 case Nkind (N) is
308 when N_Pragma | N_Generic_Declaration'Range |
309 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
310 Result := Skip;
311
312 when N_Subprogram_Body =>
313 if not Marked (Marks, Spec_Of (N)) then
314 Result := Skip;
315 end if;
316
317 when N_Package_Body_Stub =>
318 if Present (Library_Unit (N)) then
319 Traverse (Proper_Body (Unit (Library_Unit (N))));
320 end if;
321
322 when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
323 E := Entity (N);
324
325 if E /= Empty and then not Marked (Marks, E) then
326 Process (E);
327
328 if Is_Subprogram (E) then
329 B := Body_Of (E);
330
331 if B /= Empty then
332 Traverse (B);
333 end if;
334 end if;
335 end if;
336
337 when N_Entity'Range =>
338 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
339 if Present (Discriminant_Checking_Func (N)) then
340 Process (Discriminant_Checking_Func (N));
341 end if;
342 end if;
343
344 Set_Marked (Marks, N);
345
346 when others =>
347 null;
348 end case;
349
350 return Result;
351 end Process;
352
353 -- Start of processing for Trace_Marked
354
355 begin
356 Traverse (Root);
357 end Trace_Marked;
358
359 end Live;