-- 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 Ada.Unchecked_Deallocation;
with Types; use Types;
with Nodes;
with Nodes_Meta; use Nodes_Meta;
with Errorout; use Errorout;
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;
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
use Ada.Text_IO;
begin
Put ("early reference to ");
Put (Nodes_Meta.Get_Field_Image (F));
Put (" in ");
Disp_Tree.Disp_Tree (N, True);
Has_Error := True;
end Report_Early_Reference;
procedure Report_Already_Marked (N : Iir)
is
use Ada.Text_IO;
begin
Put ("Already marked ");
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
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_Iir_List_Ref (N : Iir_List; F : Fields_Enum)
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;
if not Markers (El) then
Report_Early_Reference (El, F);
end if;
end loop;
end case;
end Mark_Iir_List_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
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_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;
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
for I in Natural loop
El := Get_Nth_Element (List, I);
exit when El = Null_Iir;
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;
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 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 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 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
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;
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;