* c-cppbuiltin.c (c_cpp_builtins): Use ggc_strdup for the fp_suffix
[official-gcc.git] / gcc / ada / live.adb
blobd73b9068a59d79f71dda319953250f47a575de2d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- L I V E --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2000-2018, 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 ------------------------------------------------------------------------------
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;
35 package body Live is
37 -- Name_Set
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.
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);
50 procedure Set_Marked
51 (Marks : in out Name_Set;
52 Name : Node_Id;
53 Mark : Boolean := True);
54 pragma Inline (Set_Marked);
56 -- Algorithm
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 applies
70 -- 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. 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.
77 -- Local functions
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
86 -- should be fixed.
88 -------------
89 -- Body_Of --
90 -------------
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;
97 begin
98 if Kind = N_Subprogram_Body then
99 Result := Decl;
101 elsif Kind /= N_Subprogram_Declaration
102 and Kind /= N_Subprogram_Body_Stub
103 then
104 Result := Empty;
106 else
107 Result := Corresponding_Body (Decl);
109 if Result /= Empty then
110 Result := Unit_Declaration_Node (Result);
111 end if;
112 end if;
114 return Result;
115 end Body_Of;
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);
125 begin
126 Mark (Root, Marks);
127 Sweep (Root, Marks);
128 end Collect_Garbage_Entities;
130 -----------------
131 -- Init_Marked --
132 -----------------
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 -------------
140 -- Process --
141 -------------
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;
151 Set_Marked (Marks, N, Is_Public (N));
153 when N_Subprogram_Body =>
154 Traverse (Spec_Of (N));
156 when N_Package_Body_Stub =>
157 if Present (Library_Unit (N)) then
158 Traverse (Proper_Body (Unit (Library_Unit (N))));
159 end if;
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;
171 when others =>
172 null;
173 end case;
175 return OK;
176 end Process;
178 -- Start of processing for Init_Marked
180 begin
181 Marks := (others => False);
182 Traverse (Root);
183 end Init_Marked;
185 ----------
186 -- Mark --
187 ----------
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;
195 ------------
196 -- Marked --
197 ------------
199 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
200 begin
201 return Marks (Name);
202 end Marked;
204 ----------------
205 -- Set_Marked --
206 ----------------
208 procedure Set_Marked
209 (Marks : in out Name_Set;
210 Name : Node_Id;
211 Mark : Boolean := True)
213 begin
214 Marks (Name) := Mark;
215 end Set_Marked;
217 -------------
218 -- Spec_Of --
219 -------------
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;
230 -----------
231 -- Sweep --
232 -----------
234 procedure Sweep (Root : Node_Id; Marks : Name_Set) is
236 function Process (N : Node_Id) return Traverse_Result;
237 procedure Traverse is new Traverse_Proc (Process);
239 -------------
240 -- Process --
241 -------------
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));
249 when N_Subprogram_Body =>
250 Traverse (Spec_Of (N));
252 when N_Package_Body_Stub =>
253 if Present (Library_Unit (N)) then
254 Traverse (Proper_Body (Unit (Library_Unit (N))));
255 end if;
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;
267 when others =>
268 null;
269 end case;
271 return OK;
272 end Process;
274 -- Start of processing for Sweep
276 begin
277 Traverse (Root);
278 end Sweep;
280 ------------------
281 -- Trace_Marked --
282 ------------------
284 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
286 function Process (N : Node_Id) return Traverse_Result;
287 procedure Process (N : Node_Id);
288 procedure Traverse is new Traverse_Proc (Process);
290 -------------
291 -- Process --
292 -------------
294 procedure Process (N : Node_Id) is
295 Result : Traverse_Result;
296 pragma Warnings (Off, Result);
298 begin
299 Result := Process (N);
300 end Process;
302 function Process (N : Node_Id) return Traverse_Result is
303 Result : Traverse_Result := OK;
304 B : Node_Id;
305 E : Entity_Id;
307 begin
308 case Nkind (N) is
309 when N_Generic_Declaration'Range
310 | N_Pragma
311 | N_Subprogram_Body_Stub
312 | N_Subprogram_Declaration
314 Result := Skip;
316 when N_Subprogram_Body =>
317 if not Marked (Marks, Spec_Of (N)) then
318 Result := Skip;
319 end if;
321 when N_Package_Body_Stub =>
322 if Present (Library_Unit (N)) then
323 Traverse (Proper_Body (Unit (Library_Unit (N))));
324 end if;
326 when N_Expanded_Name
327 | N_Identifier
328 | N_Operator_Symbol
330 E := Entity (N);
332 if E /= Empty and then not Marked (Marks, E) then
333 Process (E);
335 if Is_Subprogram (E) then
336 B := Body_Of (E);
338 if B /= Empty then
339 Traverse (B);
340 end if;
341 end if;
342 end if;
344 when N_Entity'Range =>
345 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
346 if Present (Discriminant_Checking_Func (N)) then
347 Process (Discriminant_Checking_Func (N));
348 end if;
349 end if;
351 Set_Marked (Marks, N);
353 when others =>
354 null;
355 end case;
357 return Result;
358 end Process;
360 -- Start of processing for Trace_Marked
362 begin
363 Traverse (Root);
364 end Trace_Marked;
366 end Live;