nodes_gc: move checks in libraries (WIP)

5 files changed, 71 insertions, 27 deletions

diff --git a/src/flags.ads b/src/flags.ads
index 4bb6ec486..dc6dcc96d 100644
--- a/src/flags.ads
+++ b/src/flags.ads
@@ -67,6 +67,10 @@ package Flags is
    --  -dstats: disp statistics.
    Dump_Stats : Boolean := False;
 
+   --  If not 0, do internal consistency and leaks check on the AST after
+   --  analysis.
+   Check_Ast_Level : Natural := 0;
+
    -- -lX options: list tree as a vhdl file.
 
    -- --lall option: makes -lX options to apply to all files
diff --git a/src/ghdldrv/ghdlcomp.adb b/src/ghdldrv/ghdlcomp.adb
index 5d7dd7a28..18ed69380 100644
--- a/src/ghdldrv/ghdlcomp.adb
+++ b/src/ghdldrv/ghdlcomp.adb
@@ -24,7 +24,6 @@ with Ada.Text_IO;
 
 with Types;
 with Iirs; use Iirs;
-with Nodes_GC;
 with Flags;
 with Sem;
 with Name_Table;
@@ -38,9 +37,6 @@ package body Ghdlcomp is
 
    Flag_Expect_Failure : Boolean := False;
 
-   Flag_Debug_Nodes_Leak : Boolean := False;
-   --  If True, detect unreferenced nodes at the end of analysis.
-
    --  Commands which use the mcode compiler.
    type Command_Comp is abstract new Command_Lib with null record;
    procedure Decode_Option (Cmd : in out Command_Comp;
@@ -58,8 +54,8 @@ package body Ghdlcomp is
       if Option = "--expect-failure" then
          Flag_Expect_Failure := True;
          Res := Option_Ok;
-      elsif Option = "--debug-nodes-leak" then
-         Flag_Debug_Nodes_Leak := True;
+      elsif Option = "--check-ast" then
+         Flags.Check_Ast_Level := Flags.Check_Ast_Level + 1;
          Res := Option_Ok;
       elsif Hooks.Decode_Option.all (Option) then
          Res := Option_Ok;
@@ -377,10 +373,6 @@ package body Ghdlcomp is
          raise Compilation_Error;
       end if;
 
-      if Flag_Debug_Nodes_Leak then
-         Nodes_GC.Report_Unreferenced;
-      end if;
-
       Libraries.Save_Work_Library;
 
    exception
diff --git a/src/libraries.adb b/src/libraries.adb
index bb8b69089..4258eeaea 100644
--- a/src/libraries.adb
+++ b/src/libraries.adb
@@ -37,6 +37,7 @@ with Disp_Vhdl;
 with Sem;
 with Post_Sems;
 with Canon;
+with Nodes_GC;
 
 package body Libraries is
    --  Chain of known libraries.  This is also the top node of all iir node.
@@ -1556,6 +1557,10 @@ package body Libraries is
          Disp_Tree.Disp_Tree (Unit);
       end if;
 
+      if Flags.Check_Ast_Level > 0 then
+         Nodes_GC.Check_Tree (Unit);
+      end if;
+
       if Flags.Verbose then
          Report_Msg (Msgid_Note, Semantic, +Lib_Unit,
                      "analyze %n", (1 => +Lib_Unit));
diff --git a/src/vhdl/nodes_gc.adb b/src/vhdl/nodes_gc.adb
index 9b1c34cf7..99343222f 100644
--- a/src/vhdl/nodes_gc.adb
+++ b/src/vhdl/nodes_gc.adb
@@ -17,11 +17,11 @@
 --  02111-1307, USA.
 
 with Ada.Text_IO;
+with Ada.Unchecked_Deallocation;
 with Types; use Types;
 with Nodes;
 with Nodes_Meta; use Nodes_Meta;
 with Errorout; use Errorout;
-with Iirs; use Iirs;
 with Libraries;
 with Disp_Tree;
 with Std_Package;
@@ -35,6 +35,9 @@ package body Nodes_GC is
 
    Markers : Marker_Array_Acc;
 
+   procedure Free is new Ada.Unchecked_Deallocation
+     (Marker_Array, Marker_Array_Acc);
+
    procedure Mark_Iir (N : Iir);
 
    procedure Mark_Iir_List (N : Iir_List)
@@ -242,6 +245,8 @@ package body Nodes_GC is
          return;
       end if;
 
+      Markers (Get_Design_File (Unit)) := True;
+
       --  First mark dependences
       List := Get_Dependence_List (Unit);
       if List /= Null_Iir_List then
@@ -273,12 +278,11 @@ package body Nodes_GC is
       Mark_Iir (Unit);
    end Mark_Unit;
 
-   procedure Report_Unreferenced
+   --  Initialize the mark process.  Create the array and mark some unrooted
+   --  but referenced nodes in std_package.
+   procedure Mark_Init
    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);
 
@@ -287,7 +291,29 @@ package body Nodes_GC is
       --  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 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;
@@ -355,20 +381,20 @@ package body Nodes_GC is
             Unit := Get_Chain (Unit);
          end loop;
       end;
+   end Mark_Units_Of_All_Libraries;
 
-      --  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);
+   procedure Report_Unreferenced
+   is
+      use Ada.Text_IO;
+      use 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
@@ -382,8 +408,20 @@ package body Nodes_GC is
          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 Nodes_GC;
diff --git a/src/vhdl/nodes_gc.ads b/src/vhdl/nodes_gc.ads
index ad17c67b7..9b92b9e8b 100644
--- a/src/vhdl/nodes_gc.ads
+++ b/src/vhdl/nodes_gc.ads
@@ -16,9 +16,14 @@
 --  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
 --  02111-1307, USA.
 
+with Iirs; use Iirs;
+
 package Nodes_GC is
    Flag_Disp_Multiref : Boolean := True;
 
+   --  Perform an internal check on the tree structure of UNIT.
+   procedure Check_Tree (Unit : Iir);
+
    procedure Report_Unreferenced;
    --  Display nodes that aren't referenced.
 end Nodes_GC;