1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2019, 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_Aux; use Sem_Aux;
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 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
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 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.
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);
143 function Process (N : Node_Id) return Traverse_Result is
146 when N_Entity'Range =>
147 if Is_Eliminated (N) then
148 Set_Is_Public (N, False);
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))));
161 when N_Package_Body =>
163 Elmt : Node_Id := First (Declarations (N));
165 while Present (Elmt) loop
178 -- Start of processing for Init_Marked
181 Marks := (others => False);
189 procedure Mark (Root : Node_Id; Marks : out Name_Set) is
191 Init_Marked (Root, Marks);
192 Trace_Marked (Root, Marks);
199 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
209 (Marks : in out Name_Set;
211 Mark : Boolean := True)
214 Marks (Name) := Mark;
221 function Spec_Of (N : Node_Id) return Entity_Id is
223 if Acts_As_Spec (N) then
224 return Defining_Entity (N);
226 return Corresponding_Spec (N);
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);
243 function Process (N : Node_Id) return Traverse_Result 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))));
257 when N_Package_Body =>
259 Elmt : Node_Id := First (Declarations (N));
261 while Present (Elmt) loop
274 -- Start of processing for Sweep
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);
294 procedure Process (N : Node_Id) is
295 Result : Traverse_Result;
296 pragma Warnings (Off, Result);
299 Result := Process (N);
302 function Process (N : Node_Id) return Traverse_Result is
303 Result : Traverse_Result := OK;
309 when N_Generic_Declaration'Range
311 | N_Subprogram_Body_Stub
312 | N_Subprogram_Declaration
316 when N_Subprogram_Body =>
317 if not Marked (Marks, Spec_Of (N)) then
321 when N_Package_Body_Stub =>
322 if Present (Library_Unit (N)) then
323 Traverse (Proper_Body (Unit (Library_Unit (N))));
332 if E /= Empty and then not Marked (Marks, E) then
335 if Is_Subprogram (E) then
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));
351 Set_Marked (Marks, N);
360 -- Start of processing for Trace_Marked