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