1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Atree
; use Atree
;
29 with Einfo
; use Einfo
;
31 with Nlists
; use Nlists
;
32 with Sem_Util
; use Sem_Util
;
33 with Sinfo
; use Sinfo
;
34 with Types
; use Types
;
40 -- The Name_Set type is used to store the temporary mark bits
41 -- used by the garbage collection of entities. Using a separate
42 -- array prevents using up any valuable per-node space and possibly
43 -- results in better locality and cache usage.
45 type Name_Set
is array (Node_Id
range <>) of Boolean;
46 pragma Pack
(Name_Set
);
48 function Marked
(Marks
: Name_Set
; Name
: Node_Id
) return Boolean;
49 pragma Inline
(Marked
);
52 (Marks
: in out Name_Set
;
54 Mark
: Boolean := True);
55 pragma Inline
(Set_Marked
);
59 -- The problem of finding live entities is solved in two steps:
61 procedure Mark
(Root
: Node_Id
; Marks
: out Name_Set
);
62 -- Mark all live entities in Root as Marked.
64 procedure Sweep
(Root
: Node_Id
; Marks
: Name_Set
);
65 -- For all unmarked entities in Root set Is_Eliminated to true
67 -- The Mark phase is split into two phases:
69 procedure Init_Marked
(Root
: Node_Id
; Marks
: out Name_Set
);
70 -- For all subprograms, reset Is_Public flag if a pragma Eliminate
71 -- applies to the entity, and set the Marked flag to Is_Public
73 procedure Trace_Marked
(Root
: Node_Id
; Marks
: in out Name_Set
);
74 -- Traverse the tree skipping any unmarked subprogram bodies.
75 -- All visited entities are marked, as well as entities denoted
76 -- by a visited identifier or operator. When an entity is first
77 -- marked it is traced as well.
81 function Body_Of
(E
: Entity_Id
) return Node_Id
;
82 -- Returns subprogram body corresponding to entity E
84 function Spec_Of
(N
: Node_Id
) return Entity_Id
;
85 -- Given a subprogram body N, return defining identifier of its declaration
87 -- ??? the body of this package contains no comments at all, this
94 function Body_Of
(E
: Entity_Id
) return Node_Id
is
95 Decl
: Node_Id
:= Unit_Declaration_Node
(E
);
97 Kind
: Node_Kind
:= Nkind
(Decl
);
100 if Kind
= N_Subprogram_Body
then
103 elsif Kind
/= N_Subprogram_Declaration
104 and Kind
/= N_Subprogram_Body_Stub
109 Result
:= Corresponding_Body
(Decl
);
111 if Result
/= Empty
then
112 Result
:= Unit_Declaration_Node
(Result
);
119 ------------------------------
120 -- Collect_Garbage_Entities --
121 ------------------------------
123 procedure Collect_Garbage_Entities
is
124 Root
: constant Node_Id
:= Cunit
(Main_Unit
);
125 Marks
: Name_Set
(0 .. Last_Node_Id
);
130 end Collect_Garbage_Entities
;
136 procedure Init_Marked
(Root
: Node_Id
; Marks
: out Name_Set
) is
138 function Process
(N
: Node_Id
) return Traverse_Result
;
139 procedure Traverse
is new Traverse_Proc
(Process
);
141 function Process
(N
: Node_Id
) return Traverse_Result
is
144 when N_Entity
'Range =>
145 if Is_Eliminated
(N
) then
146 Set_Is_Public
(N
, False);
149 Set_Marked
(Marks
, N
, Is_Public
(N
));
151 when N_Subprogram_Body
=>
152 Traverse
(Spec_Of
(N
));
154 when N_Package_Body_Stub
=>
155 if Present
(Library_Unit
(N
)) then
156 Traverse
(Proper_Body
(Unit
(Library_Unit
(N
))));
159 when N_Package_Body
=>
161 Elmt
: Node_Id
:= First
(Declarations
(N
));
163 while Present
(Elmt
) loop
176 -- Start of processing for Init_Marked
179 Marks
:= (others => False);
187 procedure Mark
(Root
: Node_Id
; Marks
: out Name_Set
) is
189 Init_Marked
(Root
, Marks
);
190 Trace_Marked
(Root
, Marks
);
197 function Marked
(Marks
: Name_Set
; Name
: Node_Id
) return Boolean is
207 (Marks
: in out Name_Set
;
209 Mark
: Boolean := True)
212 Marks
(Name
) := Mark
;
219 function Spec_Of
(N
: Node_Id
) return Entity_Id
is
221 if Acts_As_Spec
(N
) then
222 return Defining_Entity
(N
);
224 return Corresponding_Spec
(N
);
232 procedure Sweep
(Root
: Node_Id
; Marks
: Name_Set
) is
234 function Process
(N
: Node_Id
) return Traverse_Result
;
235 procedure Traverse
is new Traverse_Proc
(Process
);
237 function Process
(N
: Node_Id
) return Traverse_Result
is
240 when N_Entity
'Range =>
241 Set_Is_Eliminated
(N
, not Marked
(Marks
, N
));
243 when N_Subprogram_Body
=>
244 Traverse
(Spec_Of
(N
));
246 when N_Package_Body_Stub
=>
247 if Present
(Library_Unit
(N
)) then
248 Traverse
(Proper_Body
(Unit
(Library_Unit
(N
))));
251 when N_Package_Body
=>
253 Elmt
: Node_Id
:= First
(Declarations
(N
));
255 while Present
(Elmt
) loop
275 procedure Trace_Marked
(Root
: Node_Id
; Marks
: in out Name_Set
) is
277 function Process
(N
: Node_Id
) return Traverse_Result
;
278 procedure Process
(N
: Node_Id
);
279 procedure Traverse
is new Traverse_Proc
(Process
);
281 procedure Process
(N
: Node_Id
) is
282 Result
: Traverse_Result
;
284 Result
:= Process
(N
);
287 function Process
(N
: Node_Id
) return Traverse_Result
is
288 Result
: Traverse_Result
:= OK
;
294 when N_Pragma | N_Generic_Declaration
'Range |
295 N_Subprogram_Declaration | N_Subprogram_Body_Stub
=>
298 when N_Subprogram_Body
=>
299 if not Marked
(Marks
, Spec_Of
(N
)) then
303 when N_Package_Body_Stub
=>
304 if Present
(Library_Unit
(N
)) then
305 Traverse
(Proper_Body
(Unit
(Library_Unit
(N
))));
308 when N_Identifier | N_Operator_Symbol | N_Expanded_Name
=>
311 if E
/= Empty
and then not Marked
(Marks
, E
) then
314 if Is_Subprogram
(E
) then
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
));
330 Set_Marked
(Marks
, N
);
339 -- Start of processing for Trace_Marked