1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I V E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2019, 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 used by the 40 -- garbage collection of entities. Using a separate array prevents using up 41 -- any valuable per-node space and possibly results in better locality and 42 -- 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 applies 70 -- 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. All visited 74 -- entities are marked, as well as entities denoted by a visited identifier 75 -- or operator. When an entity is first 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 ------------- 140 -- Process -- 141 ------------- 142 143 function Process (N : Node_Id) return Traverse_Result is 144 begin 145 case Nkind (N) is 146 when N_Entity'Range => 147 if Is_Eliminated (N) then 148 Set_Is_Public (N, False); 149 end if; 150 151 Set_Marked (Marks, N, Is_Public (N)); 152 153 when N_Subprogram_Body => 154 Traverse (Spec_Of (N)); 155 156 when N_Package_Body_Stub => 157 if Present (Library_Unit (N)) then 158 Traverse (Proper_Body (Unit (Library_Unit (N)))); 159 end if; 160 161 when N_Package_Body => 162 declare 163 Elmt : Node_Id := First (Declarations (N)); 164 begin 165 while Present (Elmt) loop 166 Traverse (Elmt); 167 Next (Elmt); 168 end loop; 169 end; 170 171 when others => 172 null; 173 end case; 174 175 return OK; 176 end Process; 177 178 -- Start of processing for Init_Marked 179 180 begin 181 Marks := (others => False); 182 Traverse (Root); 183 end Init_Marked; 184 185 ---------- 186 -- Mark -- 187 ---------- 188 189 procedure Mark (Root : Node_Id; Marks : out Name_Set) is 190 begin 191 Init_Marked (Root, Marks); 192 Trace_Marked (Root, Marks); 193 end Mark; 194 195 ------------ 196 -- Marked -- 197 ------------ 198 199 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is 200 begin 201 return Marks (Name); 202 end Marked; 203 204 ---------------- 205 -- Set_Marked -- 206 ---------------- 207 208 procedure Set_Marked 209 (Marks : in out Name_Set; 210 Name : Node_Id; 211 Mark : Boolean := True) 212 is 213 begin 214 Marks (Name) := Mark; 215 end Set_Marked; 216 217 ------------- 218 -- Spec_Of -- 219 ------------- 220 221 function Spec_Of (N : Node_Id) return Entity_Id is 222 begin 223 if Acts_As_Spec (N) then 224 return Defining_Entity (N); 225 else 226 return Corresponding_Spec (N); 227 end if; 228 end Spec_Of; 229 230 ----------- 231 -- Sweep -- 232 ----------- 233 234 procedure Sweep (Root : Node_Id; Marks : Name_Set) is 235 236 function Process (N : Node_Id) return Traverse_Result; 237 procedure Traverse is new Traverse_Proc (Process); 238 239 ------------- 240 -- Process -- 241 ------------- 242 243 function Process (N : Node_Id) return Traverse_Result is 244 begin 245 case Nkind (N) is 246 when N_Entity'Range => 247 Set_Is_Eliminated (N, not Marked (Marks, N)); 248 249 when N_Subprogram_Body => 250 Traverse (Spec_Of (N)); 251 252 when N_Package_Body_Stub => 253 if Present (Library_Unit (N)) then 254 Traverse (Proper_Body (Unit (Library_Unit (N)))); 255 end if; 256 257 when N_Package_Body => 258 declare 259 Elmt : Node_Id := First (Declarations (N)); 260 begin 261 while Present (Elmt) loop 262 Traverse (Elmt); 263 Next (Elmt); 264 end loop; 265 end; 266 267 when others => 268 null; 269 end case; 270 271 return OK; 272 end Process; 273 274 -- Start of processing for Sweep 275 276 begin 277 Traverse (Root); 278 end Sweep; 279 280 ------------------ 281 -- Trace_Marked -- 282 ------------------ 283 284 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is 285 286 function Process (N : Node_Id) return Traverse_Result; 287 procedure Process (N : Node_Id); 288 procedure Traverse is new Traverse_Proc (Process); 289 290 ------------- 291 -- Process -- 292 ------------- 293 294 procedure Process (N : Node_Id) is 295 Result : Traverse_Result; 296 pragma Warnings (Off, Result); 297 298 begin 299 Result := Process (N); 300 end Process; 301 302 function Process (N : Node_Id) return Traverse_Result is 303 Result : Traverse_Result := OK; 304 B : Node_Id; 305 E : Entity_Id; 306 307 begin 308 case Nkind (N) is 309 when N_Generic_Declaration'Range 310 | N_Pragma 311 | N_Subprogram_Body_Stub 312 | N_Subprogram_Declaration 313 => 314 Result := Skip; 315 316 when N_Subprogram_Body => 317 if not Marked (Marks, Spec_Of (N)) then 318 Result := Skip; 319 end if; 320 321 when N_Package_Body_Stub => 322 if Present (Library_Unit (N)) then 323 Traverse (Proper_Body (Unit (Library_Unit (N)))); 324 end if; 325 326 when N_Expanded_Name 327 | N_Identifier 328 | N_Operator_Symbol 329 => 330 E := Entity (N); 331 332 if E /= Empty and then not Marked (Marks, E) then 333 Process (E); 334 335 if Is_Subprogram (E) then 336 B := Body_Of (E); 337 338 if B /= Empty then 339 Traverse (B); 340 end if; 341 end if; 342 end if; 343 344 when N_Entity'Range => 345 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then 346 if Present (Discriminant_Checking_Func (N)) then 347 Process (Discriminant_Checking_Func (N)); 348 end if; 349 end if; 350 351 Set_Marked (Marks, N); 352 353 when others => 354 null; 355 end case; 356 357 return Result; 358 end Process; 359 360 -- Start of processing for Trace_Marked 361 362 begin 363 Traverse (Root); 364 end Trace_Marked; 365 366end Live; 367