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