OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [live.adb] - Blame information for rev 410

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                                 L I V E                                  --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 2000-2007, 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
 
26
with Atree;    use Atree;
27
with Einfo;    use Einfo;
28
with Lib;      use Lib;
29
with Nlists;   use Nlists;
30
with Sem_Util; use Sem_Util;
31
with Sinfo;    use Sinfo;
32
with Types;    use Types;
33
 
34
package body Live is
35
 
36
   --  Name_Set
37
 
38
   --  The Name_Set type is used to store the temporary mark bits
39
   --  used by the garbage collection of entities. Using a separate
40
   --  array prevents using up any valuable per-node space and possibly
41
   --  results in better locality and cache usage.
42
 
43
   type Name_Set is array (Node_Id range <>) of Boolean;
44
   pragma Pack (Name_Set);
45
 
46
   function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
47
   pragma Inline (Marked);
48
 
49
   procedure Set_Marked
50
     (Marks : in out Name_Set;
51
      Name  : Node_Id;
52
      Mark  : Boolean := True);
53
   pragma Inline (Set_Marked);
54
 
55
   --  Algorithm
56
 
57
   --  The problem of finding live entities is solved in two steps:
58
 
59
   procedure Mark (Root : Node_Id; Marks : out Name_Set);
60
   --  Mark all live entities in Root as Marked
61
 
62
   procedure Sweep (Root : Node_Id; Marks : Name_Set);
63
   --  For all unmarked entities in Root set Is_Eliminated to true
64
 
65
   --  The Mark phase is split into two phases:
66
 
67
   procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
68
   --  For all subprograms, reset Is_Public flag if a pragma Eliminate
69
   --  applies to the entity, and set the Marked flag to Is_Public
70
 
71
   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
72
   --  Traverse the tree skipping any unmarked subprogram bodies.
73
   --  All visited entities are marked, as well as entities denoted
74
   --  by a visited identifier or operator. When an entity is first
75
   --  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
      function Process (N : Node_Id) return Traverse_Result is
140
      begin
141
         case Nkind (N) is
142
            when N_Entity'Range =>
143
               if Is_Eliminated (N) then
144
                  Set_Is_Public (N, False);
145
               end if;
146
 
147
               Set_Marked (Marks, N, Is_Public (N));
148
 
149
            when N_Subprogram_Body =>
150
               Traverse (Spec_Of (N));
151
 
152
            when N_Package_Body_Stub =>
153
               if Present (Library_Unit (N)) then
154
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
155
               end if;
156
 
157
            when N_Package_Body =>
158
               declare
159
                  Elmt : Node_Id := First (Declarations (N));
160
               begin
161
                  while Present (Elmt) loop
162
                     Traverse (Elmt);
163
                     Next (Elmt);
164
                  end loop;
165
               end;
166
 
167
            when others =>
168
               null;
169
         end case;
170
 
171
         return OK;
172
      end Process;
173
 
174
   --  Start of processing for Init_Marked
175
 
176
   begin
177
      Marks := (others => False);
178
      Traverse (Root);
179
   end Init_Marked;
180
 
181
   ----------
182
   -- Mark --
183
   ----------
184
 
185
   procedure Mark (Root : Node_Id; Marks : out Name_Set) is
186
   begin
187
      Init_Marked (Root, Marks);
188
      Trace_Marked (Root, Marks);
189
   end Mark;
190
 
191
   ------------
192
   -- Marked --
193
   ------------
194
 
195
   function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
196
   begin
197
      return Marks (Name);
198
   end Marked;
199
 
200
   ----------------
201
   -- Set_Marked --
202
   ----------------
203
 
204
   procedure Set_Marked
205
     (Marks : in out Name_Set;
206
      Name  : Node_Id;
207
      Mark  : Boolean := True)
208
   is
209
   begin
210
      Marks (Name) := Mark;
211
   end Set_Marked;
212
 
213
   -------------
214
   -- Spec_Of --
215
   -------------
216
 
217
   function Spec_Of (N : Node_Id) return Entity_Id is
218
   begin
219
      if Acts_As_Spec (N) then
220
         return Defining_Entity (N);
221
      else
222
         return Corresponding_Spec (N);
223
      end if;
224
   end Spec_Of;
225
 
226
   -----------
227
   -- Sweep --
228
   -----------
229
 
230
   procedure Sweep (Root : Node_Id; Marks : Name_Set) is
231
 
232
      function Process (N : Node_Id) return Traverse_Result;
233
      procedure Traverse is new Traverse_Proc (Process);
234
 
235
      function Process (N : Node_Id) return Traverse_Result is
236
      begin
237
         case Nkind (N) is
238
            when N_Entity'Range =>
239
               Set_Is_Eliminated (N, not Marked (Marks, N));
240
 
241
            when N_Subprogram_Body =>
242
               Traverse (Spec_Of (N));
243
 
244
            when N_Package_Body_Stub =>
245
               if Present (Library_Unit (N)) then
246
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
247
               end if;
248
 
249
            when N_Package_Body =>
250
               declare
251
                  Elmt : Node_Id := First (Declarations (N));
252
               begin
253
                  while Present (Elmt) loop
254
                     Traverse (Elmt);
255
                     Next (Elmt);
256
                  end loop;
257
               end;
258
 
259
            when others =>
260
               null;
261
         end case;
262
         return OK;
263
      end Process;
264
 
265
   begin
266
      Traverse (Root);
267
   end Sweep;
268
 
269
   ------------------
270
   -- Trace_Marked --
271
   ------------------
272
 
273
   procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
274
 
275
      function  Process (N : Node_Id) return Traverse_Result;
276
      procedure Process (N : Node_Id);
277
      procedure Traverse is new Traverse_Proc (Process);
278
 
279
      procedure Process (N : Node_Id) is
280
         Result : Traverse_Result;
281
         pragma Warnings (Off, Result);
282
 
283
      begin
284
         Result := Process (N);
285
      end Process;
286
 
287
      function Process (N : Node_Id) return Traverse_Result is
288
         Result : Traverse_Result := OK;
289
         B      : Node_Id;
290
         E      : Entity_Id;
291
 
292
      begin
293
         case Nkind (N) is
294
            when N_Pragma | N_Generic_Declaration'Range |
295
                 N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
296
               Result := Skip;
297
 
298
            when N_Subprogram_Body =>
299
               if not Marked (Marks, Spec_Of (N)) then
300
                  Result := Skip;
301
               end if;
302
 
303
            when N_Package_Body_Stub =>
304
               if Present (Library_Unit (N)) then
305
                  Traverse (Proper_Body (Unit (Library_Unit (N))));
306
               end if;
307
 
308
            when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
309
               E := Entity (N);
310
 
311
               if E /= Empty and then not Marked (Marks, E) then
312
                  Process (E);
313
 
314
                  if Is_Subprogram (E) then
315
                     B := Body_Of (E);
316
 
317
                     if B /= Empty then
318
                        Traverse (B);
319
                     end if;
320
                  end if;
321
               end if;
322
 
323
            when N_Entity'Range =>
324
               if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
325
                  if Present (Discriminant_Checking_Func (N)) then
326
                     Process (Discriminant_Checking_Func (N));
327
                  end if;
328
               end if;
329
 
330
               Set_Marked (Marks, N);
331
 
332
            when others =>
333
               null;
334
         end case;
335
 
336
         return Result;
337
      end Process;
338
 
339
   --  Start of processing for Trace_Marked
340
 
341
   begin
342
      Traverse (Root);
343
   end Trace_Marked;
344
 
345
end Live;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.