aboutsummaryrefslogtreecommitdiffstats
path: root/src/vhdl/vhdl-nodes_gc.adb
diff options
context:
space:
mode:
Diffstat (limited to 'src/vhdl/vhdl-nodes_gc.adb')
-rw-r--r--src/vhdl/vhdl-nodes_gc.adb519
1 files changed, 519 insertions, 0 deletions
diff --git a/src/vhdl/vhdl-nodes_gc.adb b/src/vhdl/vhdl-nodes_gc.adb
new file mode 100644
index 000000000..8876528ff
--- /dev/null
+++ b/src/vhdl/vhdl-nodes_gc.adb
@@ -0,0 +1,519 @@
+-- Node garbage collector (for debugging).
+-- Copyright (C) 2014 Tristan Gingold
+--
+-- GHDL is free software; you can redistribute it and/or modify it under
+-- the terms of the GNU General Public License as published by the Free
+-- Software Foundation; either version 2, or (at your option) any later
+-- version.
+--
+-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
+-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
+-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+-- for more details.
+--
+-- You should have received a copy of the GNU General Public License
+-- along with GHDL; see the file COPYING. If not, write to the Free
+-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
+-- 02111-1307, USA.
+
+with Ada.Unchecked_Deallocation;
+with Types; use Types;
+with Logging; use Logging;
+with Nodes;
+with Nodes_Meta; use Nodes_Meta;
+with Errorout; use Errorout;
+with Libraries;
+with Vhdl.Disp_Tree;
+with Vhdl.Std_Package;
+
+package body Vhdl.Nodes_GC is
+
+ type Marker_Array is array (Iir range <>) of Boolean;
+ type Marker_Array_Acc is access Marker_Array;
+
+ Has_Error : Boolean := False;
+
+ Markers : Marker_Array_Acc;
+
+ procedure Free is new Ada.Unchecked_Deallocation
+ (Marker_Array, Marker_Array_Acc);
+
+ procedure Report_Early_Reference (N : Iir; F : Nodes_Meta.Fields_Enum) is
+ begin
+ Log ("early reference to ");
+ Log (Nodes_Meta.Get_Field_Image (F));
+ Log (" in ");
+ Vhdl.Disp_Tree.Disp_Tree (N, True);
+ Has_Error := True;
+ end Report_Early_Reference;
+
+ procedure Report_Already_Marked (N : Iir) is
+ begin
+ Log ("Already marked ");
+ Vhdl.Disp_Tree.Disp_Tree (N, True);
+ Has_Error := True;
+ end Report_Already_Marked;
+
+ procedure Mark_Iir (N : Iir);
+
+ procedure Mark_Iir_List (N : Iir_List)
+ is
+ It : List_Iterator;
+ begin
+ case N is
+ when Null_Iir_List
+ | Iir_List_All =>
+ null;
+ when others =>
+ It := List_Iterate (N);
+ while Is_Valid (It) loop
+ Mark_Iir (Get_Element (It));
+ Next (It);
+ end loop;
+ end case;
+ end Mark_Iir_List;
+
+ procedure Mark_Iir_List_Ref (N : Iir_List; F : Fields_Enum)
+ is
+ El : Iir;
+ It : List_Iterator;
+ begin
+ case N is
+ when Null_Iir_List
+ | Iir_List_All =>
+ null;
+ when others =>
+ It := List_Iterate (N);
+ while Is_Valid (It) loop
+ El := Get_Element (It);
+ if not Markers (El) then
+ Report_Early_Reference (El, F);
+ end if;
+ Next (It);
+ end loop;
+ end case;
+ end Mark_Iir_List_Ref;
+
+ procedure Mark_Iir_Flist (N : Iir_Flist)
+ is
+ El : Iir;
+ begin
+ case N is
+ when Null_Iir_Flist
+ | Iir_Flist_All
+ | Iir_Flist_Others =>
+ null;
+ when others =>
+ for I in Flist_First .. Flist_Last (N) loop
+ El := Get_Nth_Element (N, I);
+ Mark_Iir (El);
+ end loop;
+ end case;
+ end Mark_Iir_Flist;
+
+ procedure Mark_Iir_Flist_Ref (N : Iir_Flist; F : Fields_Enum)
+ is
+ El : Iir;
+ begin
+ case N is
+ when Null_Iir_Flist
+ | Iir_Flist_All
+ | Iir_Flist_Others =>
+ null;
+ when others =>
+ for I in Flist_First .. Flist_Last (N) loop
+ El := Get_Nth_Element (N, I);
+ if not Markers (El) then
+ Report_Early_Reference (El, F);
+ end if;
+ end loop;
+ end case;
+ end Mark_Iir_Flist_Ref;
+
+ procedure Mark_PSL_Node (N : PSL_Node) is
+ begin
+ null;
+ end Mark_PSL_Node;
+
+ procedure Mark_PSL_NFA (N : PSL_NFA) is
+ begin
+ null;
+ end Mark_PSL_NFA;
+
+ procedure Already_Marked (N : Iir) is
+ begin
+ -- An unused node mustn't be referenced.
+ if Get_Kind (N) = Iir_Kind_Unused then
+ raise Internal_Error;
+ end if;
+
+ if not Flag_Disp_Multiref then
+ return;
+ end if;
+
+ case Get_Kind (N) is
+ when Iir_Kind_Interface_Constant_Declaration =>
+ if Get_Identifier (N) = Null_Identifier then
+ -- Anonymous interfaces are shared by predefined functions.
+ return;
+ end if;
+ when others =>
+ null;
+ end case;
+
+ Report_Already_Marked (N);
+ end Already_Marked;
+
+ procedure Mark_Chain (Head : Iir)
+ is
+ El : Iir;
+ begin
+ El := Head;
+ while El /= Null_Iir loop
+ Mark_Iir (El);
+ El := Get_Chain (El);
+ end loop;
+ end Mark_Chain;
+
+ procedure Report_Unreferenced_Node (N : Iir) is
+ begin
+ Vhdl.Disp_Tree.Disp_Tree (N, True);
+ Has_Error := True;
+ end Report_Unreferenced_Node;
+
+ procedure Mark_Iir_Ref_Field (N : Iir; F : Fields_Enum)
+ is
+ Nf : constant Iir := Get_Iir (N, F);
+ begin
+ if Is_Valid (Nf) and then not Markers (Nf) then
+ Report_Early_Reference (N, F);
+ end if;
+ end Mark_Iir_Ref_Field;
+
+ procedure Mark_Iir (N : Iir) is
+ begin
+ if N = Null_Iir then
+ return;
+ elsif Markers (N) then
+ Already_Marked (N);
+ return;
+ else
+ Markers (N) := True;
+ end if;
+
+ declare
+ Fields : constant Fields_Array := Get_Fields (Get_Kind (N));
+ F : Fields_Enum;
+ begin
+ for I in Fields'Range loop
+ F := Fields (I);
+ case Get_Field_Type (F) is
+ when Type_Iir =>
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Mark_Iir (Get_Iir (N, F));
+ when Attr_Ref =>
+ Mark_Iir_Ref_Field (N, F);
+ when Attr_Forward_Ref
+ | Attr_Chain_Next =>
+ null;
+ when Attr_Maybe_Forward_Ref =>
+ -- Only used for Named_Entity
+ pragma Assert (F = Field_Named_Entity);
+
+ -- Overload_List has to be handled specially, as it
+ -- that case the Ref applies to the elements of the
+ -- list.
+ declare
+ Nf : constant Iir := Get_Iir (N, F);
+ begin
+ if Nf /= Null_Iir then
+ if Get_Is_Forward_Ref (N) then
+ pragma Assert
+ (Get_Kind (Nf) /= Iir_Kind_Overload_List);
+ null;
+ else
+ if Get_Kind (Nf) = Iir_Kind_Overload_List then
+ Mark_Iir (Nf);
+ else
+ Mark_Iir_Ref_Field (N, F);
+ end if;
+ end if;
+ end if;
+ end;
+ when Attr_Maybe_Ref =>
+ if Get_Is_Ref (N) then
+ Mark_Iir_Ref_Field (N, F);
+ else
+ Mark_Iir (Get_Iir (N, F));
+ end if;
+ when Attr_Chain =>
+ Mark_Chain (Get_Iir (N, F));
+ when Attr_Of_Ref | Attr_Of_Maybe_Ref =>
+ raise Internal_Error;
+ end case;
+ when Type_Iir_List =>
+ declare
+ Ref : Boolean;
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Ref := False;
+ when Attr_Of_Ref =>
+ Ref := True;
+ when Attr_Of_Maybe_Ref =>
+ Ref := Get_Is_Ref (N);
+ when Attr_Ref =>
+ Ref := True;
+ when others =>
+ raise Internal_Error;
+ end case;
+ if Ref then
+ Mark_Iir_List_Ref (Get_Iir_List (N, F), F);
+ else
+ Mark_Iir_List (Get_Iir_List (N, F));
+ end if;
+ end;
+ when Type_Iir_Flist =>
+ declare
+ Ref : Boolean;
+ begin
+ case Get_Field_Attribute (F) is
+ when Attr_None =>
+ Ref := False;
+ when Attr_Of_Ref =>
+ Ref := True;
+ when Attr_Of_Maybe_Ref =>
+ Ref := Get_Is_Ref (N);
+ when Attr_Ref =>
+ Ref := True;
+ when others =>
+ raise Internal_Error;
+ end case;
+ if Ref then
+ Mark_Iir_Flist_Ref (Get_Iir_Flist (N, F), F);
+ else
+ Mark_Iir_Flist (Get_Iir_Flist (N, F));
+ end if;
+ end;
+ when Type_PSL_Node =>
+ Mark_PSL_Node (Get_PSL_Node (N, F));
+ when Type_PSL_NFA =>
+ Mark_PSL_NFA (Get_PSL_NFA (N, F));
+ when others =>
+ null;
+ end case;
+ end loop;
+ end;
+ end Mark_Iir;
+
+ procedure Mark_Unit (Unit : Iir)
+ is
+ List : Iir_List;
+ It : List_Iterator;
+ El : Iir;
+ begin
+ pragma Assert (Get_Kind (Unit) = Iir_Kind_Design_Unit);
+ if Markers (Unit) then
+ return;
+ end if;
+
+ -- Mark parents of UNIT.
+ declare
+ File : constant Iir := Get_Design_File (Unit);
+ Lib : constant Iir := Get_Library (File);
+ begin
+ Markers (File) := True;
+ Markers (Lib) := True;
+ end;
+
+ -- First mark dependences
+ List := Get_Dependence_List (Unit);
+ if List /= Null_Iir_List then
+ It := List_Iterate (List);
+ while Is_Valid (It) loop
+ El := Get_Element (It);
+ case Get_Kind (El) is
+ when Iir_Kind_Design_Unit =>
+ Mark_Unit (El);
+ when Iir_Kind_Entity_Aspect_Entity =>
+ declare
+ Ent : constant Iir := Get_Entity_Name (El);
+ Arch_Name : constant Iir := Get_Architecture (El);
+ Arch : Iir;
+ begin
+ Mark_Unit (Get_Design_Unit (Get_Named_Entity (Ent)));
+
+ -- Architecture is optional.
+ if Is_Valid (Arch_Name) then
+ Arch := Get_Named_Entity (Arch_Name);
+ -- There are many possibilities for the architecture.
+ if Is_Valid (Arch) then
+ case Get_Kind (Arch) is
+ when Iir_Kind_Design_Unit =>
+ null;
+ when Iir_Kind_Architecture_Body =>
+ Arch := Get_Design_Unit (Arch);
+ when others =>
+ Error_Kind ("mark_unit", Arch);
+ end case;
+ Mark_Unit (Arch);
+ end if;
+ end if;
+ end;
+ when others =>
+ Error_Kind ("mark_unit", El);
+ end case;
+ Next (It);
+ end loop;
+ end if;
+
+ Mark_Iir (Unit);
+ end Mark_Unit;
+
+ -- Initialize the mark process. Create the array and mark some unrooted
+ -- but referenced nodes in std_package.
+ procedure Mark_Init
+ is
+ use Vhdl.Std_Package;
+ begin
+ Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False);
+
+ Has_Error := False;
+
+ -- Node not owned, but used for "/" (time, time).
+ Markers (Convertible_Integer_Type_Definition) := True;
+ Markers (Convertible_Real_Type_Definition) := True;
+ end Mark_Init;
+
+ -- Marks known nodes that aren't owned.
+ procedure Mark_Not_Owned
+ is
+ use Vhdl.Std_Package;
+ begin
+ -- These nodes are owned by type/subtype declarations, so unmark them
+ -- before marking their owner.
+ Markers (Convertible_Integer_Type_Definition) := False;
+ Markers (Convertible_Real_Type_Definition) := False;
+
+ -- These nodes are not rooted.
+ Mark_Iir (Convertible_Integer_Type_Declaration);
+ Mark_Iir (Convertible_Integer_Subtype_Declaration);
+ Mark_Iir (Convertible_Real_Type_Declaration);
+ Mark_Iir (Universal_Integer_One);
+ Mark_Chain (Wildcard_Type_Declaration_Chain);
+ Mark_Iir (Error_Mark);
+ end Mark_Not_Owned;
+
+ procedure Mark_Units_Of_All_Libraries is
+ begin
+ -- The user nodes.
+ declare
+ Lib : Iir;
+ File : Iir;
+ Unit : Iir;
+ begin
+ -- First mark all known libraries and file.
+ Lib := Libraries.Get_Libraries_Chain;
+ while Is_Valid (Lib) loop
+ pragma Assert (Get_Kind (Lib) = Iir_Kind_Library_Declaration);
+ pragma Assert (not Markers (Lib));
+ Markers (Lib) := True;
+ File := Get_Design_File_Chain (Lib);
+ while Is_Valid (File) loop
+ pragma Assert (Get_Kind (File) = Iir_Kind_Design_File);
+ pragma Assert (not Markers (File));
+ Markers (File) := True;
+ File := Get_Chain (File);
+ end loop;
+ Lib := Get_Chain (Lib);
+ end loop;
+
+ -- Then mark all design units. This has to consider first the
+ -- dependencies.
+ Lib := Libraries.Get_Libraries_Chain;
+ while Is_Valid (Lib) loop
+ pragma Assert (Get_Kind (Lib) = Iir_Kind_Library_Declaration);
+ File := Get_Design_File_Chain (Lib);
+ while Is_Valid (File) loop
+ pragma Assert (Get_Kind (File) = Iir_Kind_Design_File);
+ Unit := Get_First_Design_Unit (File);
+ while Is_Valid (Unit) loop
+ Mark_Unit (Unit);
+ Unit := Get_Chain (Unit);
+ end loop;
+ File := Get_Chain (File);
+ end loop;
+ Lib := Get_Chain (Lib);
+ end loop;
+ end;
+
+ -- Obsoleted units.
+ declare
+ Unit : Iir;
+ begin
+ Unit := Libraries.Obsoleted_Design_Units;
+ while Is_Valid (Unit) loop
+ pragma Assert (Get_Kind (Unit) = Iir_Kind_Design_Unit);
+ -- FIXME: obsoleted units may be in various state:
+ -- - unit created by the .cf file and replaced by the loaded one
+ -- (should have been free)
+ -- - unit directly obsoleted by a new unit in the same file
+ -- - unit indirectly obsoleted.
+ if Get_Date_State (Unit) <= Date_Disk then
+ -- Never loaded unit, so not referenced and removed from its
+ -- design file.
+ -- FIXME: free it early.
+ pragma Assert (Get_Dependence_List (Unit) = Null_Iir_List);
+ Mark_Iir (Unit);
+ else
+ if not Markers (Unit) then
+ Mark_Iir (Unit);
+ end if;
+ end if;
+ Unit := Get_Chain (Unit);
+ end loop;
+ end;
+ end Mark_Units_Of_All_Libraries;
+
+ procedure Report_Unreferenced
+ is
+ use Vhdl.Std_Package;
+ El : Iir;
+ Nbr_Unreferenced : Natural;
+ begin
+ Mark_Init;
+ Mark_Units_Of_All_Libraries;
+ Mark_Not_Owned;
+
+ -- Iterate on all nodes, and report nodes not marked.
+ El := Error_Mark;
+ Nbr_Unreferenced := 0;
+ while El in Markers'Range loop
+ if not Markers (El) and then Get_Kind (El) /= Iir_Kind_Unused then
+ if Nbr_Unreferenced = 0 then
+ Log_Line ("** unreferenced nodes:");
+ end if;
+ Nbr_Unreferenced := Nbr_Unreferenced + 1;
+ Report_Unreferenced_Node (El);
+ end if;
+ El := Iir (Nodes.Next_Node (Nodes.Node_Type (El)));
+ end loop;
+
+ Free (Markers);
+
+ if Has_Error then
+ raise Internal_Error;
+ end if;
+ end Report_Unreferenced;
+
+ procedure Check_Tree (Unit : Iir) is
+ begin
+ Mark_Init;
+ Mark_Unit (Unit);
+ Free (Markers);
+ if Has_Error then
+ raise Internal_Error;
+ end if;
+ end Check_Tree;
+end Vhdl.Nodes_GC;
generated by cgit v1.2.3 (git 2.25.1) at 2024-08-12 13:02:34 +0000