1-- Node garbage collector (for debugging). 2-- Copyright (C) 2014 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16 17with Ada.Unchecked_Deallocation; 18with Types; use Types; 19with Logging; use Logging; 20with Vhdl.Nodes_Meta; use Vhdl.Nodes_Meta; 21with Vhdl.Errors; use Vhdl.Errors; 22with Libraries; 23with Vhdl.Disp_Tree; 24with Vhdl.Std_Package; 25with PSL.Types; use PSL.Types; 26 27package body Vhdl.Nodes_GC is 28 29 type Marker_Array is array (Iir range <>) of Boolean; 30 type Marker_Array_Acc is access Marker_Array; 31 32 Has_Error : Boolean := False; 33 34 Markers : Marker_Array_Acc; 35 36 procedure Free is new Ada.Unchecked_Deallocation 37 (Marker_Array, Marker_Array_Acc); 38 39 procedure Report_Early_Reference (N : Iir; F : Nodes_Meta.Fields_Enum) is 40 begin 41 Log ("early reference to "); 42 Log (Nodes_Meta.Get_Field_Image (F)); 43 Log (" in "); 44 Vhdl.Disp_Tree.Disp_Tree (N, True); 45 Has_Error := True; 46 end Report_Early_Reference; 47 48 procedure Report_Already_Marked (N : Iir) is 49 begin 50 Log ("Already marked "); 51 Vhdl.Disp_Tree.Disp_Tree (N, True); 52 Has_Error := True; 53 end Report_Already_Marked; 54 55 procedure Mark_Iir (N : Iir); 56 57 procedure Mark_Iir_List (N : Iir_List) 58 is 59 It : List_Iterator; 60 begin 61 case N is 62 when Null_Iir_List 63 | Iir_List_All => 64 null; 65 when others => 66 It := List_Iterate (N); 67 while Is_Valid (It) loop 68 Mark_Iir (Get_Element (It)); 69 Next (It); 70 end loop; 71 end case; 72 end Mark_Iir_List; 73 74 procedure Mark_Iir_List_Ref (N : Iir_List; F : Fields_Enum) 75 is 76 El : Iir; 77 It : List_Iterator; 78 begin 79 case N is 80 when Null_Iir_List 81 | Iir_List_All => 82 null; 83 when others => 84 It := List_Iterate (N); 85 while Is_Valid (It) loop 86 El := Get_Element (It); 87 if not Markers (El) then 88 Report_Early_Reference (El, F); 89 end if; 90 Next (It); 91 end loop; 92 end case; 93 end Mark_Iir_List_Ref; 94 95 procedure Mark_Iir_Flist (N : Iir_Flist) 96 is 97 El : Iir; 98 begin 99 case N is 100 when Null_Iir_Flist 101 | Iir_Flist_All 102 | Iir_Flist_Others => 103 null; 104 when others => 105 for I in Flist_First .. Flist_Last (N) loop 106 El := Get_Nth_Element (N, I); 107 Mark_Iir (El); 108 end loop; 109 end case; 110 end Mark_Iir_Flist; 111 112 procedure Mark_Iir_Flist_Ref (N : Iir_Flist; F : Fields_Enum) 113 is 114 El : Iir; 115 begin 116 case N is 117 when Null_Iir_Flist 118 | Iir_Flist_All 119 | Iir_Flist_Others => 120 null; 121 when others => 122 for I in Flist_First .. Flist_Last (N) loop 123 El := Get_Nth_Element (N, I); 124 if not Markers (El) then 125 Report_Early_Reference (El, F); 126 end if; 127 end loop; 128 end case; 129 end Mark_Iir_Flist_Ref; 130 131 procedure Mark_PSL_Node (N : PSL_Node) is 132 begin 133 null; 134 end Mark_PSL_Node; 135 136 procedure Mark_PSL_NFA (N : PSL_NFA) is 137 begin 138 null; 139 end Mark_PSL_NFA; 140 141 procedure Already_Marked (N : Iir) is 142 begin 143 -- An unused node mustn't be referenced. 144 if Get_Kind (N) = Iir_Kind_Unused then 145 raise Internal_Error; 146 end if; 147 148 if not Flag_Disp_Multiref then 149 return; 150 end if; 151 152 case Get_Kind (N) is 153 when Iir_Kind_Interface_Constant_Declaration => 154 if Get_Identifier (N) = Null_Identifier then 155 -- Anonymous interfaces are shared by predefined functions. 156 return; 157 end if; 158 when others => 159 null; 160 end case; 161 162 Report_Already_Marked (N); 163 end Already_Marked; 164 165 procedure Mark_Chain (Head : Iir) 166 is 167 El : Iir; 168 begin 169 El := Head; 170 while El /= Null_Iir loop 171 Mark_Iir (El); 172 El := Get_Chain (El); 173 end loop; 174 end Mark_Chain; 175 176 procedure Report_Unreferenced_Node (N : Iir) is 177 begin 178 Vhdl.Disp_Tree.Disp_Tree (N, True); 179 Has_Error := True; 180 end Report_Unreferenced_Node; 181 182 procedure Mark_Iir_Ref_Field (N : Iir; F : Fields_Enum) 183 is 184 Nf : constant Iir := Get_Iir (N, F); 185 begin 186 if Is_Valid (Nf) and then not Markers (Nf) then 187 Report_Early_Reference (N, F); 188 end if; 189 end Mark_Iir_Ref_Field; 190 191 procedure Mark_Iir (N : Iir) is 192 begin 193 if N = Null_Iir then 194 return; 195 elsif Markers (N) then 196 Already_Marked (N); 197 return; 198 else 199 Markers (N) := True; 200 end if; 201 202 declare 203 Fields : constant Fields_Array := Get_Fields (Get_Kind (N)); 204 F : Fields_Enum; 205 begin 206 for I in Fields'Range loop 207 F := Fields (I); 208 case Get_Field_Type (F) is 209 when Type_Iir => 210 case Get_Field_Attribute (F) is 211 when Attr_None => 212 Mark_Iir (Get_Iir (N, F)); 213 when Attr_Ref => 214 Mark_Iir_Ref_Field (N, F); 215 when Attr_Forward_Ref 216 | Attr_Chain_Next => 217 null; 218 when Attr_Maybe_Forward_Ref => 219 -- Only used for Named_Entity 220 pragma Assert (F = Field_Named_Entity); 221 222 -- Overload_List has to be handled specially, as it 223 -- that case the Ref applies to the elements of the 224 -- list. 225 declare 226 Nf : constant Iir := Get_Iir (N, F); 227 begin 228 if Nf /= Null_Iir then 229 if Get_Is_Forward_Ref (N) then 230 pragma Assert 231 (Get_Kind (Nf) /= Iir_Kind_Overload_List); 232 null; 233 else 234 if Get_Kind (Nf) = Iir_Kind_Overload_List then 235 Mark_Iir (Nf); 236 else 237 Mark_Iir_Ref_Field (N, F); 238 end if; 239 end if; 240 end if; 241 end; 242 when Attr_Maybe_Ref => 243 if Get_Is_Ref (N) then 244 Mark_Iir_Ref_Field (N, F); 245 else 246 Mark_Iir (Get_Iir (N, F)); 247 end if; 248 when Attr_Chain => 249 Mark_Chain (Get_Iir (N, F)); 250 when Attr_Of_Ref | Attr_Of_Maybe_Ref => 251 raise Internal_Error; 252 end case; 253 when Type_Iir_List => 254 declare 255 Ref : Boolean; 256 begin 257 case Get_Field_Attribute (F) is 258 when Attr_None => 259 Ref := False; 260 when Attr_Of_Ref => 261 Ref := True; 262 when Attr_Of_Maybe_Ref => 263 Ref := Get_Is_Ref (N); 264 when Attr_Ref => 265 Ref := True; 266 when others => 267 raise Internal_Error; 268 end case; 269 if Ref then 270 Mark_Iir_List_Ref (Get_Iir_List (N, F), F); 271 else 272 Mark_Iir_List (Get_Iir_List (N, F)); 273 end if; 274 end; 275 when Type_Iir_Flist => 276 declare 277 Ref : Boolean; 278 begin 279 case Get_Field_Attribute (F) is 280 when Attr_None => 281 Ref := False; 282 when Attr_Of_Ref => 283 Ref := True; 284 when Attr_Of_Maybe_Ref => 285 Ref := Get_Is_Ref (N); 286 when Attr_Ref => 287 Ref := True; 288 when others => 289 raise Internal_Error; 290 end case; 291 if Ref then 292 Mark_Iir_Flist_Ref (Get_Iir_Flist (N, F), F); 293 else 294 Mark_Iir_Flist (Get_Iir_Flist (N, F)); 295 end if; 296 end; 297 when Type_PSL_Node => 298 Mark_PSL_Node (Get_PSL_Node (N, F)); 299 when Type_PSL_NFA => 300 Mark_PSL_NFA (Get_PSL_NFA (N, F)); 301 when others => 302 null; 303 end case; 304 end loop; 305 end; 306 end Mark_Iir; 307 308 procedure Mark_Unit (Unit : Iir) 309 is 310 List : Iir_List; 311 It : List_Iterator; 312 El : Iir; 313 begin 314 pragma Assert (Get_Kind (Unit) = Iir_Kind_Design_Unit); 315 if Markers (Unit) then 316 return; 317 end if; 318 319 -- Mark parents of UNIT. 320 declare 321 File : constant Iir := Get_Design_File (Unit); 322 Lib : constant Iir := Get_Library (File); 323 begin 324 Markers (File) := True; 325 Markers (Lib) := True; 326 end; 327 328 -- First mark dependences 329 List := Get_Dependence_List (Unit); 330 if List /= Null_Iir_List then 331 It := List_Iterate (List); 332 while Is_Valid (It) loop 333 El := Get_Element (It); 334 case Get_Kind (El) is 335 when Iir_Kind_Design_Unit => 336 Mark_Unit (El); 337 when Iir_Kind_Entity_Aspect_Entity => 338 declare 339 Ent : constant Iir := Get_Entity_Name (El); 340 Arch_Name : constant Iir := Get_Architecture (El); 341 Arch : Iir; 342 begin 343 Mark_Unit (Get_Design_Unit (Get_Named_Entity (Ent))); 344 345 -- Architecture is optional. 346 if Is_Valid (Arch_Name) then 347 Arch := Get_Named_Entity (Arch_Name); 348 -- There are many possibilities for the architecture. 349 if Is_Valid (Arch) then 350 case Get_Kind (Arch) is 351 when Iir_Kind_Design_Unit => 352 null; 353 when Iir_Kind_Architecture_Body => 354 Arch := Get_Design_Unit (Arch); 355 when others => 356 Error_Kind ("mark_unit", Arch); 357 end case; 358 Mark_Unit (Arch); 359 end if; 360 end if; 361 end; 362 when others => 363 Error_Kind ("mark_unit", El); 364 end case; 365 Next (It); 366 end loop; 367 end if; 368 369 Mark_Iir (Unit); 370 end Mark_Unit; 371 372 -- Initialize the mark process. Create the array and mark some unrooted 373 -- but referenced nodes in std_package. 374 procedure Mark_Init 375 is 376 use Vhdl.Std_Package; 377 begin 378 Markers := new Marker_Array'(Null_Iir .. Nodes.Get_Last_Node => False); 379 380 Has_Error := False; 381 382 -- Node not owned, but used for "/" (time, time). 383 Markers (Convertible_Integer_Type_Definition) := True; 384 Markers (Convertible_Real_Type_Definition) := True; 385 end Mark_Init; 386 387 -- Marks known nodes that aren't owned. 388 procedure Mark_Not_Owned 389 is 390 use Vhdl.Std_Package; 391 begin 392 -- These nodes are owned by type/subtype declarations, so unmark them 393 -- before marking their owner. 394 Markers (Convertible_Integer_Type_Definition) := False; 395 Markers (Convertible_Real_Type_Definition) := False; 396 397 -- These nodes are not rooted. 398 Mark_Iir (Convertible_Integer_Type_Declaration); 399 Mark_Iir (Convertible_Integer_Subtype_Declaration); 400 Mark_Iir (Convertible_Real_Type_Declaration); 401 Mark_Iir (Universal_Integer_One); 402 Mark_Chain (Wildcard_Type_Declaration_Chain); 403 Mark_Iir (Error_Mark); 404 end Mark_Not_Owned; 405 406 procedure Mark_Units_Of_All_Libraries is 407 begin 408 -- The user nodes. 409 declare 410 Lib : Iir; 411 File : Iir; 412 Unit : Iir; 413 begin 414 -- First mark all known libraries and file. 415 Lib := Libraries.Get_Libraries_Chain; 416 while Is_Valid (Lib) loop 417 pragma Assert (Get_Kind (Lib) = Iir_Kind_Library_Declaration); 418 pragma Assert (not Markers (Lib)); 419 Markers (Lib) := True; 420 File := Get_Design_File_Chain (Lib); 421 while Is_Valid (File) loop 422 pragma Assert (Get_Kind (File) = Iir_Kind_Design_File); 423 pragma Assert (not Markers (File)); 424 Markers (File) := True; 425 File := Get_Chain (File); 426 end loop; 427 Lib := Get_Chain (Lib); 428 end loop; 429 430 -- Then mark all design units. This has to consider first the 431 -- dependencies. 432 Lib := Libraries.Get_Libraries_Chain; 433 while Is_Valid (Lib) loop 434 pragma Assert (Get_Kind (Lib) = Iir_Kind_Library_Declaration); 435 File := Get_Design_File_Chain (Lib); 436 while Is_Valid (File) loop 437 pragma Assert (Get_Kind (File) = Iir_Kind_Design_File); 438 Unit := Get_First_Design_Unit (File); 439 while Is_Valid (Unit) loop 440 Mark_Unit (Unit); 441 Unit := Get_Chain (Unit); 442 end loop; 443 File := Get_Chain (File); 444 end loop; 445 Lib := Get_Chain (Lib); 446 end loop; 447 end; 448 449 -- Obsoleted units. 450 declare 451 Unit : Iir; 452 begin 453 Unit := Libraries.Obsoleted_Design_Units; 454 while Is_Valid (Unit) loop 455 pragma Assert (Get_Kind (Unit) = Iir_Kind_Design_Unit); 456 -- FIXME: obsoleted units may be in various state: 457 -- - unit created by the .cf file and replaced by the loaded one 458 -- (should have been free) 459 -- - unit directly obsoleted by a new unit in the same file 460 -- - unit indirectly obsoleted. 461 if Get_Date_State (Unit) <= Date_Disk then 462 -- Never loaded unit, so not referenced and removed from its 463 -- design file. 464 -- FIXME: free it early. 465 pragma Assert (Get_Dependence_List (Unit) = Null_Iir_List); 466 Mark_Iir (Unit); 467 else 468 if not Markers (Unit) then 469 Mark_Iir (Unit); 470 end if; 471 end if; 472 Unit := Get_Chain (Unit); 473 end loop; 474 end; 475 end Mark_Units_Of_All_Libraries; 476 477 procedure Report_Unreferenced 478 is 479 use Vhdl.Std_Package; 480 El : Iir; 481 Nbr_Unreferenced : Natural; 482 begin 483 Mark_Init; 484 Mark_Units_Of_All_Libraries; 485 Mark_Not_Owned; 486 487 -- Iterate on all nodes, and report nodes not marked. 488 El := Error_Mark; 489 Nbr_Unreferenced := 0; 490 while El in Markers'Range loop 491 if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then 492 if Nbr_Unreferenced = 0 then 493 Log_Line ("** unreferenced nodes:"); 494 end if; 495 Nbr_Unreferenced := Nbr_Unreferenced + 1; 496 Report_Unreferenced_Node (El); 497 end if; 498 El := Next_Node (El); 499 end loop; 500 501 Free (Markers); 502 503 if Has_Error then 504 raise Internal_Error; 505 end if; 506 end Report_Unreferenced; 507 508 procedure Check_Tree (Unit : Iir) is 509 begin 510 Mark_Init; 511 Mark_Unit (Unit); 512 Free (Markers); 513 if Has_Error then 514 raise Internal_Error; 515 end if; 516 end Check_Tree; 517end Vhdl.Nodes_GC; 518