1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                 L I V E                                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2000-2019, 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
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Lib;      use Lib;
29with Nlists;   use Nlists;
30with Sem_Aux;  use Sem_Aux;
31with Sem_Util; use Sem_Util;
32with Sinfo;    use Sinfo;
33with Types;    use Types;
34
35package 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
271         return OK;
272      end Process;
273
274   --  Start of processing for Sweep
275
276   begin
277      Traverse (Root);
278   end Sweep;
279
280   ------------------
281   -- Trace_Marked --
282   ------------------
283
284   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
285
286      function  Process (N : Node_Id) return Traverse_Result;
287      procedure Process (N : Node_Id);
288      procedure Traverse is new Traverse_Proc (Process);
289
290      -------------
291      -- Process --
292      -------------
293
294      procedure Process (N : Node_Id) is
295         Result : Traverse_Result;
296         pragma Warnings (Off, Result);
297
298      begin
299         Result := Process (N);
300      end Process;
301
302      function Process (N : Node_Id) return Traverse_Result is
303         Result : Traverse_Result := OK;
304         B      : Node_Id;
305         E      : Entity_Id;
306
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
313            =>
314               Result := Skip;
315
316            when N_Subprogram_Body =>
317               if not Marked (Marks, Spec_Of (N)) then
318                  Result := Skip;
319               end if;
320
321            when N_Package_Body_Stub =>
322               if Present (Library_Unit (N)) then
323                  Traverse (Proper_Body (Unit (Library_Unit (N))));
324               end if;
325
326            when N_Expanded_Name
327               | N_Identifier
328               | N_Operator_Symbol
329            =>
330               E := Entity (N);
331
332               if E /= Empty and then not Marked (Marks, E) then
333                  Process (E);
334
335                  if Is_Subprogram (E) then
336                     B := Body_Of (E);
337
338                     if B /= Empty then
339                        Traverse (B);
340                     end if;
341                  end if;
342               end if;
343
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;
350
351               Set_Marked (Marks, N);
352
353            when others =>
354               null;
355         end case;
356
357         return Result;
358      end Process;
359
360   --  Start of processing for Trace_Marked
361
362   begin
363      Traverse (Root);
364   end Trace_Marked;
365
366end Live;
367