Create src/vhdl subdirectory.

1 files changed, 206 insertions, 0 deletions

diff --git a/src/vhdl/nodes_gc.adb b/src/vhdl/nodes_gc.adb
new file mode 100644
index 0000000..38966f2
--- /dev/null
+++ b/src/vhdl/nodes_gc.adb
@@ -0,0 +1,206 @@
+--  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.Text_IO;
+with Types; use Types;
+with Nodes;
+with Nodes_Meta;
+with Iirs; use Iirs;
+with Libraries;
+with Disp_Tree;
+with Std_Package;
+
+package body Nodes_GC is
+
+   type Marker_Array is array (Iir range <>) of Boolean;
+   type Marker_Array_Acc is access Marker_Array;
+
+   Markers : Marker_Array_Acc;
+
+   procedure Mark_Iir (N : Iir);
+
+   procedure Mark_Iir_List (N : Iir_List)
+   is
+      El : Iir;
+   begin
+      case N is
+         when Null_Iir_List
+           | Iir_List_All
+           | Iir_List_Others =>
+            null;
+         when others =>
+            for I in Natural loop
+               El := Get_Nth_Element (N, I);
+               exit when El = Null_Iir;
+               Mark_Iir (El);
+            end loop;
+      end case;
+   end Mark_Iir_List;
+
+   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 Report_Already_Marked (N : Iir)
+   is
+      use Ada.Text_IO;
+   begin
+      Disp_Tree.Disp_Tree (N, True);
+      return;
+   end Report_Already_Marked;
+
+   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 Iir_Kind_Enumeration_Literal =>
+            if Get_Enum_Pos (N) = 0
+              or else N = Get_Right_Limit (Get_Range_Constraint
+                                             (Get_Type (N)))
+            then
+               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
+      Disp_Tree.Disp_Tree (N, True);
+   end Report_Unreferenced_Node;
+
+   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
+         use Nodes_Meta;
+         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_Attribute (F) is
+               when Attr_Ref
+                 | Attr_Chain_Next =>
+                  null;
+               when Attr_Maybe_Ref =>
+                  if not Get_Is_Ref (N) then
+                     Mark_Iir (Get_Iir (N, F));
+                  end if;
+               when Attr_Chain =>
+                  Mark_Chain (Get_Iir (N, F));
+               when Attr_None =>
+                  case Get_Field_Type (F) is
+                     when Type_Iir =>
+                        Mark_Iir (Get_Iir (N, F));
+                     when Type_Iir_List =>
+                        Mark_Iir_List (Get_Iir_List (N, F));
+                     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;
+               when Attr_Of_Ref =>
+                  raise Internal_Error;
+            end case;
+         end loop;
+      end;
+   end Mark_Iir;
+
+   procedure Report_Unreferenced
+   is
+      use Ada.Text_IO;
+      use Std_Package;
+      El : Iir;
+      Nbr_Unreferenced : Natural;
+   begin
+      Markers := new Marker_Array'(Null_Iir .. Iirs.Get_Last_Node => False);
+
+      if Flag_Disp_Multiref then
+         Put_Line ("** nodes already marked:");
+      end if;
+
+      Mark_Chain (Libraries.Get_Libraries_Chain);
+      Mark_Chain (Libraries.Obsoleted_Design_Units);
+      Mark_Iir (Convertible_Integer_Type_Declaration);
+      Mark_Iir (Convertible_Integer_Subtype_Declaration);
+      Mark_Iir (Convertible_Real_Type_Declaration);
+      Mark_Iir (Universal_Integer_One);
+      Mark_Iir (Error_Mark);
+
+      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
+               Put_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;
+
+      if Nbr_Unreferenced /= 0 then
+         raise Internal_Error;
+      end if;
+   end Report_Unreferenced;
+end Nodes_GC;