1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- L I V E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2000-2021, 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 Einfo.Entities; use Einfo.Entities; 29with Einfo.Utils; use Einfo.Utils; 30with Lib; use Lib; 31with Nlists; use Nlists; 32with Sem_Aux; use Sem_Aux; 33with Sem_Util; use Sem_Util; 34with Sinfo; use Sinfo; 35with Sinfo.Nodes; use Sinfo.Nodes; 36with Sinfo.Utils; use Sinfo.Utils; 37with Types; use Types; 38 39package body Live is 40 41 -- Name_Set 42 43 -- The Name_Set type is used to store the temporary mark bits used by the 44 -- garbage collection of entities. Using a separate array prevents using up 45 -- any valuable per-node space and possibly results in better locality and 46 -- cache usage. 47 48 type Name_Set is array (Node_Id'Base range <>) of Boolean; 49 -- We use 'Base here, in case we want to add a predicate to Node_Id 50 pragma Pack (Name_Set); 51 52 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean; 53 pragma Inline (Marked); 54 55 procedure Set_Marked 56 (Marks : in out Name_Set; 57 Name : Node_Id; 58 Mark : Boolean := True); 59 pragma Inline (Set_Marked); 60 61 -- Algorithm 62 63 -- The problem of finding live entities is solved in two steps: 64 65 procedure Mark (Root : Node_Id; Marks : out Name_Set); 66 -- Mark all live entities in Root as Marked 67 68 procedure Sweep (Root : Node_Id; Marks : Name_Set); 69 -- For all unmarked entities in Root set Is_Eliminated to true 70 71 -- The Mark phase is split into two phases: 72 73 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set); 74 -- For all subprograms, reset Is_Public flag if a pragma Eliminate applies 75 -- to the entity, and set the Marked flag to Is_Public. 76 77 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set); 78 -- Traverse the tree skipping any unmarked subprogram bodies. All visited 79 -- entities are marked, as well as entities denoted by a visited identifier 80 -- or operator. When an entity is first marked it is traced as well. 81 82 -- Local functions 83 84 function Body_Of (E : Entity_Id) return Node_Id; 85 -- Returns subprogram body corresponding to entity E 86 87 function Spec_Of (N : Node_Id) return Entity_Id; 88 -- Given a subprogram body N, return defining identifier of its declaration 89 90 ------------- 91 -- Body_Of -- 92 ------------- 93 94 function Body_Of (E : Entity_Id) return Node_Id is 95 Decl : constant Node_Id := Unit_Declaration_Node (E); 96 Kind : constant Node_Kind := Nkind (Decl); 97 Result : Node_Id; 98 99 begin 100 if Kind = N_Subprogram_Body then 101 Result := Decl; 102 103 elsif Kind /= N_Subprogram_Declaration 104 and Kind /= N_Subprogram_Body_Stub 105 then 106 Result := Empty; 107 108 else 109 Result := Corresponding_Body (Decl); 110 111 if Result /= Empty then 112 Result := Unit_Declaration_Node (Result); 113 end if; 114 end if; 115 116 return Result; 117 end Body_Of; 118 119 ------------------------------ 120 -- Collect_Garbage_Entities -- 121 ------------------------------ 122 123 procedure Collect_Garbage_Entities is 124 Root : constant Node_Id := Cunit (Main_Unit); 125 Marks : Name_Set (0 .. Last_Node_Id); 126 127 begin 128 Mark (Root, Marks); 129 Sweep (Root, Marks); 130 end Collect_Garbage_Entities; 131 132 ----------------- 133 -- Init_Marked -- 134 ----------------- 135 136 procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is 137 138 function Process (N : Node_Id) return Traverse_Result; 139 procedure Traverse is new Traverse_Proc (Process); 140 141 ------------- 142 -- Process -- 143 ------------- 144 145 function Process (N : Node_Id) return Traverse_Result is 146 begin 147 case Nkind (N) is 148 when N_Entity'Range => 149 if Is_Eliminated (N) then 150 Set_Is_Public (N, False); 151 end if; 152 153 Set_Marked (Marks, N, Is_Public (N)); 154 155 when N_Subprogram_Body => 156 Traverse (Spec_Of (N)); 157 158 when N_Package_Body_Stub => 159 if Present (Library_Unit (N)) then 160 Traverse (Proper_Body (Unit (Library_Unit (N)))); 161 end if; 162 163 when N_Package_Body => 164 declare 165 Elmt : Node_Id := First (Declarations (N)); 166 begin 167 while Present (Elmt) loop 168 Traverse (Elmt); 169 Next (Elmt); 170 end loop; 171 end; 172 173 when others => 174 null; 175 end case; 176 177 return OK; 178 end Process; 179 180 -- Start of processing for Init_Marked 181 182 begin 183 Marks := (others => False); 184 Traverse (Root); 185 end Init_Marked; 186 187 ---------- 188 -- Mark -- 189 ---------- 190 191 procedure Mark (Root : Node_Id; Marks : out Name_Set) is 192 begin 193 Init_Marked (Root, Marks); 194 Trace_Marked (Root, Marks); 195 end Mark; 196 197 ------------ 198 -- Marked -- 199 ------------ 200 201 function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is 202 begin 203 return Marks (Name); 204 end Marked; 205 206 ---------------- 207 -- Set_Marked -- 208 ---------------- 209 210 procedure Set_Marked 211 (Marks : in out Name_Set; 212 Name : Node_Id; 213 Mark : Boolean := True) 214 is 215 begin 216 Marks (Name) := Mark; 217 end Set_Marked; 218 219 ------------- 220 -- Spec_Of -- 221 ------------- 222 223 function Spec_Of (N : Node_Id) return Entity_Id is 224 begin 225 if Acts_As_Spec (N) then 226 return Defining_Entity (N); 227 else 228 return Corresponding_Spec (N); 229 end if; 230 end Spec_Of; 231 232 ----------- 233 -- Sweep -- 234 ----------- 235 236 procedure Sweep (Root : Node_Id; Marks : Name_Set) is 237 238 function Process (N : Node_Id) return Traverse_Result; 239 procedure Traverse is new Traverse_Proc (Process); 240 241 ------------- 242 -- Process -- 243 ------------- 244 245 function Process (N : Node_Id) return Traverse_Result is 246 begin 247 case Nkind (N) is 248 when N_Entity'Range => 249 Set_Is_Eliminated (N, not Marked (Marks, N)); 250 251 when N_Subprogram_Body => 252 Traverse (Spec_Of (N)); 253 254 when N_Package_Body_Stub => 255 if Present (Library_Unit (N)) then 256 Traverse (Proper_Body (Unit (Library_Unit (N)))); 257 end if; 258 259 when N_Package_Body => 260 declare 261 Elmt : Node_Id := First (Declarations (N)); 262 begin 263 while Present (Elmt) loop 264 Traverse (Elmt); 265 Next (Elmt); 266 end loop; 267 end; 268 269 when others => 270 null; 271 end case; 272 273 return OK; 274 end Process; 275 276 -- Start of processing for Sweep 277 278 begin 279 Traverse (Root); 280 end Sweep; 281 282 ------------------ 283 -- Trace_Marked -- 284 ------------------ 285 286 procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is 287 288 function Process (N : Node_Id) return Traverse_Result; 289 procedure Process (N : Node_Id); 290 procedure Traverse is new Traverse_Proc (Process); 291 292 ------------- 293 -- Process -- 294 ------------- 295 296 procedure Process (N : Node_Id) is 297 Result : Traverse_Result; 298 pragma Warnings (Off, Result); 299 300 begin 301 Result := Process (N); 302 end Process; 303 304 function Process (N : Node_Id) return Traverse_Result is 305 Result : Traverse_Result := OK; 306 B : Node_Id; 307 E : Entity_Id; 308 309 begin 310 case Nkind (N) is 311 when N_Generic_Declaration'Range 312 | N_Pragma 313 | N_Subprogram_Body_Stub 314 | N_Subprogram_Declaration 315 => 316 Result := Skip; 317 318 when N_Subprogram_Body => 319 if not Marked (Marks, Spec_Of (N)) then 320 Result := Skip; 321 end if; 322 323 when N_Package_Body_Stub => 324 if Present (Library_Unit (N)) then 325 Traverse (Proper_Body (Unit (Library_Unit (N)))); 326 end if; 327 328 when N_Expanded_Name 329 | N_Identifier 330 | N_Operator_Symbol 331 => 332 E := Entity (N); 333 334 if E /= Empty and then not Marked (Marks, E) then 335 Process (E); 336 337 if Is_Subprogram (E) then 338 B := Body_Of (E); 339 340 if B /= Empty then 341 Traverse (B); 342 end if; 343 end if; 344 end if; 345 346 when N_Entity'Range => 347 if (Ekind (N) = E_Component) and then not Marked (Marks, N) then 348 if Present (Discriminant_Checking_Func (N)) then 349 Process (Discriminant_Checking_Func (N)); 350 end if; 351 end if; 352 353 Set_Marked (Marks, N); 354 355 when others => 356 null; 357 end case; 358 359 return Result; 360 end Process; 361 362 -- Start of processing for Trace_Marked 363 364 begin 365 Traverse (Root); 366 end Trace_Marked; 367 368end Live; 369