1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                 L I V E                                  --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 2000-2013, 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
40   --  used by the garbage collection of entities. Using a separate
41   --  array prevents using up any valuable per-node space and possibly
42   --  results in better locality and 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
70   --  applies 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.
74   --  All visited entities are marked, as well as entities denoted
75   --  by a visited identifier or operator. When an entity is first
76   --  marked it is traced as well.
77
78   --  Local functions
79
80   function Body_Of (E : Entity_Id) return Node_Id;
81   --  Returns subprogram body corresponding to entity E
82
83   function Spec_Of (N : Node_Id) return Entity_Id;
84   --  Given a subprogram body N, return defining identifier of its declaration
85
86   --  ??? the body of this package contains no comments at all, this
87   --  should be fixed.
88
89   -------------
90   -- Body_Of --
91   -------------
92
93   function Body_Of (E : Entity_Id) return Node_Id is
94      Decl   : constant Node_Id   := Unit_Declaration_Node (E);
95      Kind   : constant Node_Kind := Nkind (Decl);
96      Result : Node_Id;
97
98   begin
99      if Kind = N_Subprogram_Body then
100         Result := Decl;
101
102      elsif Kind /= N_Subprogram_Declaration
103        and  Kind /= N_Subprogram_Body_Stub
104      then
105         Result := Empty;
106
107      else
108         Result := Corresponding_Body (Decl);
109
110         if Result /= Empty then
111            Result := Unit_Declaration_Node (Result);
112         end if;
113      end if;
114
115      return Result;
116   end Body_Of;
117
118   ------------------------------
119   -- Collect_Garbage_Entities --
120   ------------------------------
121
122   procedure Collect_Garbage_Entities is
123      Root  : constant Node_Id := Cunit (Main_Unit);
124      Marks : Name_Set (0 .. Last_Node_Id);
125
126   begin
127      Mark (Root, Marks);
128      Sweep (Root, Marks);
129   end Collect_Garbage_Entities;
130
131   -----------------
132   -- Init_Marked --
133   -----------------
134
135   procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
136
137      function Process (N : Node_Id) return Traverse_Result;
138      procedure Traverse is new Traverse_Proc (Process);
139
140      function Process (N : Node_Id) return Traverse_Result is
141      begin
142         case Nkind (N) is
143            when N_Entity'Range =>
144               if Is_Eliminated (N) then
145                  Set_Is_Public (N, False);
146               end if;
147
148               Set_Marked (Marks, N, Is_Public (N));
149
150            when N_Subprogram_Body =>
151               Traverse (Spec_Of (N));
152
153            when N_Package_Body_Stub =>
154               if Present (Library_Unit (N)) then
155                  Traverse (Proper_Body (Unit (Library_Unit (N))));
156               end if;
157
158            when N_Package_Body =>
159               declare
160                  Elmt : Node_Id := First (Declarations (N));
161               begin
162                  while Present (Elmt) loop
163                     Traverse (Elmt);
164                     Next (Elmt);
165                  end loop;
166               end;
167
168            when others =>
169               null;
170         end case;
171
172         return OK;
173      end Process;
174
175   --  Start of processing for Init_Marked
176
177   begin
178      Marks := (others => False);
179      Traverse (Root);
180   end Init_Marked;
181
182   ----------
183   -- Mark --
184   ----------
185
186   procedure Mark (Root : Node_Id; Marks : out Name_Set) is
187   begin
188      Init_Marked (Root, Marks);
189      Trace_Marked (Root, Marks);
190   end Mark;
191
192   ------------
193   -- Marked --
194   ------------
195
196   function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
197   begin
198      return Marks (Name);
199   end Marked;
200
201   ----------------
202   -- Set_Marked --
203   ----------------
204
205   procedure Set_Marked
206     (Marks : in out Name_Set;
207      Name  : Node_Id;
208      Mark  : Boolean := True)
209   is
210   begin
211      Marks (Name) := Mark;
212   end Set_Marked;
213
214   -------------
215   -- Spec_Of --
216   -------------
217
218   function Spec_Of (N : Node_Id) return Entity_Id is
219   begin
220      if Acts_As_Spec (N) then
221         return Defining_Entity (N);
222      else
223         return Corresponding_Spec (N);
224      end if;
225   end Spec_Of;
226
227   -----------
228   -- Sweep --
229   -----------
230
231   procedure Sweep (Root : Node_Id; Marks : Name_Set) is
232
233      function Process (N : Node_Id) return Traverse_Result;
234      procedure Traverse is new Traverse_Proc (Process);
235
236      function Process (N : Node_Id) return Traverse_Result is
237      begin
238         case Nkind (N) is
239            when N_Entity'Range =>
240               Set_Is_Eliminated (N, not Marked (Marks, N));
241
242            when N_Subprogram_Body =>
243               Traverse (Spec_Of (N));
244
245            when N_Package_Body_Stub =>
246               if Present (Library_Unit (N)) then
247                  Traverse (Proper_Body (Unit (Library_Unit (N))));
248               end if;
249
250            when N_Package_Body =>
251               declare
252                  Elmt : Node_Id := First (Declarations (N));
253               begin
254                  while Present (Elmt) loop
255                     Traverse (Elmt);
256                     Next (Elmt);
257                  end loop;
258               end;
259
260            when others =>
261               null;
262         end case;
263         return OK;
264      end Process;
265
266   begin
267      Traverse (Root);
268   end Sweep;
269
270   ------------------
271   -- Trace_Marked --
272   ------------------
273
274   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
275
276      function  Process (N : Node_Id) return Traverse_Result;
277      procedure Process (N : Node_Id);
278      procedure Traverse is new Traverse_Proc (Process);
279
280      procedure Process (N : Node_Id) is
281         Result : Traverse_Result;
282         pragma Warnings (Off, Result);
283
284      begin
285         Result := Process (N);
286      end Process;
287
288      function Process (N : Node_Id) return Traverse_Result is
289         Result : Traverse_Result := OK;
290         B      : Node_Id;
291         E      : Entity_Id;
292
293      begin
294         case Nkind (N) is
295            when N_Pragma | N_Generic_Declaration'Range |
296                 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
297               Result := Skip;
298
299            when N_Subprogram_Body =>
300               if not Marked (Marks, Spec_Of (N)) then
301                  Result := Skip;
302               end if;
303
304            when N_Package_Body_Stub =>
305               if Present (Library_Unit (N)) then
306                  Traverse (Proper_Body (Unit (Library_Unit (N))));
307               end if;
308
309            when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
310               E := Entity (N);
311
312               if E /= Empty and then not Marked (Marks, E) then
313                  Process (E);
314
315                  if Is_Subprogram (E) then
316                     B := Body_Of (E);
317
318                     if B /= Empty then
319                        Traverse (B);
320                     end if;
321                  end if;
322               end if;
323
324            when N_Entity'Range =>
325               if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
326                  if Present (Discriminant_Checking_Func (N)) then
327                     Process (Discriminant_Checking_Func (N));
328                  end if;
329               end if;
330
331               Set_Marked (Marks, N);
332
333            when others =>
334               null;
335         end case;
336
337         return Result;
338      end Process;
339
340   --  Start of processing for Trace_Marked
341
342   begin
343      Traverse (Root);
344   end Trace_Marked;
345
346end Live;
347