path: root/src/grt/grt-fst.adb

--  GHDL Run Time (GRT) - FST generator.
--  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 GCC; see the file COPYING.  If not, write to the Free
--  Software Foundation, 59 Temple Place - Suite 330, Boston, MA
--  02111-1307, USA.
--
--  As a special exception, if other files instantiate generics from this
--  unit, or you link this unit with other files to produce an executable,
--  this unit does not by itself cause the resulting executable to be
--  covered by the GNU General Public License. This exception does not
--  however invalidate any other reasons why the executable file might be
--  covered by the GNU Public License.
with Interfaces; use Interfaces;
with Interfaces.C;
with System; use System;
with Grt.Types; use Grt.Types;
with Grt.Fst_Api; use Grt.Fst_Api;
with Grt.Vcd; use Grt.Vcd;
with Grt.Avhpi; use Grt.Avhpi;
with System.Storage_Elements; --  Work around GNAT bug.
pragma Unreferenced (System.Storage_Elements);
with Grt.Errors; use Grt.Errors;
with Grt.Signals; use Grt.Signals;
with Grt.Table;
with Grt.Astdio; use Grt.Astdio;
with Grt.Hooks; use Grt.Hooks;
with Grt.Rtis; use Grt.Rtis;
with Grt.Rtis_Types; use Grt.Rtis_Types;
with Grt.Vstrings;
with Ada.Unchecked_Deallocation;
pragma Elaborate_All (Grt.Table);

package body Grt.Fst is
   --  FST format has a mechanism to declare signal aliases (if two signals
   --  in the hierarchy are the same).  Enabling this reduce the number of
   --  signals dumped, but weirdly it makes the FST file slightly bigger.
   Flag_Aliases : constant Boolean := False;

   --  Global FST context.  Set to non-NULL iff dumping signals to an FST file.
   Context : fstContext := Null_fstContext;

   --  Index type of the table of vcd variables to dump.
   type Fst_Index_Type is new Integer;

   --  Return TRUE if OPT is an option for FST.
   function Fst_Option (Opt : String) return Boolean
   is
      F : constant Natural := Opt'First;
      Fst_Filename : String_Access;
   begin
      if Opt'Length < 6 or else Opt (F .. F + 5) /= "--fst=" then
         return False;
      end if;
      if Context /= Null_fstContext then
         Error ("--fst: file already set");
         return True;
      end if;

      --  Add an extra NUL character.
      Fst_Filename := new String (1 .. Opt'Length - 6 + 1);
      Fst_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last);
      Fst_Filename (Fst_Filename'Last) := NUL;

      Context := fstWriterCreate
        (To_Ghdl_C_String (Fst_Filename.all'Address), 1);
      if Context = Null_fstContext then
         Error_C ("fst: cannot open ");
         Error_E (Fst_Filename (Fst_Filename'First .. Fst_Filename'Last - 1));
      end if;
      return True;
   end Fst_Option;

   procedure Fst_Help is
   begin
      Put_Line (" --fst=FILENAME     dump signal values into an FST file");
   end Fst_Help;

   --  Called before elaboration.
   procedure Fst_Init
   is
      Version : constant String := "GHDL FST v0" & NUL;
   begin
      if Context = Null_fstContext then
         return;
      end if;

      fstWriterSetFileType (Context, FST_FT_VHDL);
      fstWriterSetPackType (Context, FST_WR_PT_LZ4);
      fstWriterSetTimescale (Context, -15); --  fs
      fstWriterSetVersion (Context, To_Ghdl_C_String (Version'Address));
      fstWriterSetRepackOnClose (Context, 1);
      fstWriterSetParallelMode (Context, 0);
   end Fst_Init;

   type Fst_Sig_Info is record
      Wire : Verilog_Wire_Info;
      Hand : fstHandle;
   end record;

   package Fst_Table is new Grt.Table
     (Table_Component_Type => Fst_Sig_Info,
      Table_Index_Type => Fst_Index_Type,
      Table_Low_Bound => 0,
      Table_Initial => 32);

   procedure Avhpi_Error (Err : AvhpiErrorT)
   is
      pragma Unreferenced (Err);
   begin
      Put_Line ("Fst.Avhpi_Error!");
   end Avhpi_Error;

   function Equal (Left, Right : Verilog_Wire_Info) return Boolean
   is
      Len : Ghdl_Index_Type;
   begin
      if Left.Kind /= Right.Kind
        or else Left.Val /= Right.Val
      then
         return False;
      end if;

      --  Get length.
      Len := Get_Wire_Length (Left);
      if Len /= Get_Wire_Length (Right) then
         return False;
      end if;

      --  Compare signals.
      for I in 1 .. Len loop
         if Left.Sigs (I - 1) /= Right.Sigs (I - 1) then
            return False;
         end if;
      end loop;
      return True;
   end Equal;

   function Hash (El : Verilog_Wire_Info) return Ghdl_Index_Type
   is
      Len : constant Ghdl_Index_Type := Get_Wire_Length (El);
      Res : Ghdl_Index_Type;
      Iaddr : Integer_Address;
   begin
      Res := Vcd_Var_Kind'Pos (El.Kind) * 2 + Vcd_Value_Kind'Pos (El.Val);
      Res := Res + Len * 29;
      for I in 1 .. Len loop
         Iaddr := To_Integer (El.Sigs (I - 1).all'Address);
         Res := Res +
           Ghdl_Index_Type (Iaddr mod Integer_Address (Ghdl_Index_Type'Last));
      end loop;
      return Res;
   end Hash;

   --  Very simple hash table to detect aliases.
   type Bucket_Type;
   type Bucket_Acc is access Bucket_Type;

   type Bucket_Type is record
      El : Fst_Index_Type;
      Next : Bucket_Acc;
   end record;

   type Hash_Table is array (Ghdl_Index_Type range <>) of Bucket_Acc;
   type Hash_Table_Acc is access Hash_Table;

   Hash_Tab : Hash_Table_Acc;

   procedure Free_Hash_Tab
   is
      procedure Free_Hash_Table is new
        Ada.Unchecked_Deallocation (Hash_Table, Hash_Table_Acc);
      procedure Free_Bucket_Type is new
        Ada.Unchecked_Deallocation (Bucket_Type, Bucket_Acc);
      Ent, Nent : Bucket_Acc;
   begin
      for I in Hash_Tab'Range loop
         Ent := Hash_Tab (I);
         while Ent /= null loop
            Nent := Ent.Next;
            Free_Bucket_Type (Ent);
            Ent := Nent;
         end loop;
      end loop;
      Free_Hash_Table (Hash_Tab);
   end Free_Hash_Tab;

   procedure Fst_Add_Signal (Sig : VhpiHandleT)
   is
      Sig_Type, Sig_Base_Type : VhpiHandleT;
      Err : AvhpiErrorT;
      Vcd_El : Verilog_Wire_Info;
      Vt : fstVarType;
      Sdt : fstSupplementalDataType;
      Dir : fstVarDir;
      Len : Interfaces.C.unsigned;
      Name : String (1 .. 128);
      Name_Len : Natural;
      Type_Name : String (1 .. 32);
      Type_Name_Len : Natural;
      Type_C_Name : Ghdl_C_String;
      Hand : fstHandle;
      Alias : fstHandle;
      H : Ghdl_Index_Type;
   begin
      Get_Verilog_Wire (Sig, Vcd_El);

      case Vcd_El.Kind is
         when Vcd_Bad =>
            --  Not handled.
            return;
         when Vcd_Bool =>
            Vt := FST_VT_VCD_REG;
            Len := 1;
            Sdt := FST_SDT_VHDL_BOOLEAN;
         when Vcd_Integer32 =>
            Vt := FST_VT_VCD_INTEGER;
            Len := 1;
            Sdt := FST_SDT_VHDL_INTEGER;
         when Vcd_Float64 =>
            Vt := FST_VT_VCD_REAL;
            Len := 1;
            Sdt := FST_SDT_VHDL_REAL;
         when Vcd_Bit =>
            Vt := FST_VT_VCD_REG;
            Len := 1;
            Sdt := FST_SDT_VHDL_BIT;
         when Vcd_Stdlogic =>
            Vt := FST_VT_VCD_REG;
            Len := 1;
            Sdt := FST_SDT_VHDL_STD_LOGIC;
         when Vcd_Bitvector =>
            Vt := FST_VT_VCD_REG;
            Len := Interfaces.C.unsigned (Vcd_El.Irange.I32.Len);
            Sdt := FST_SDT_VHDL_BIT_VECTOR;
         when Vcd_Stdlogic_Vector =>
            Vt := FST_VT_VCD_REG;
            Len := Interfaces.C.unsigned (Vcd_El.Irange.I32.Len);
            Sdt := FST_SDT_VHDL_STD_LOGIC_VECTOR;
      end case;

      if Vhpi_Get_Kind (Sig) = VhpiPortDeclK then
         case Vhpi_Get_Mode (Sig) is
            when VhpiInMode =>
               Dir := FST_VD_INPUT;
            when VhpiInoutMode =>
               Dir := FST_VD_INOUT;
            when VhpiBufferMode =>
               Dir := FST_VD_BUFFER;
            when VhpiLinkageMode =>
               Dir := FST_VD_LINKAGE;
            when VhpiOutMode =>
               Dir := FST_VD_OUTPUT;
            when VhpiErrorMode =>
               Dir := FST_VD_IMPLICIT;
         end case;
      else
         Dir := FST_VD_IMPLICIT;
      end if;

      --  Try to find an alias.
      Alias := Null_fstHandle;
      if Flag_Aliases then
         declare
            Ent : Bucket_Acc;
         begin
            H := Hash (Vcd_El) mod (Hash_Tab'Last + 1);
            Ent := Hash_Tab (H);
            while Ent /= null loop
               if Equal (Fst_Table.Table (Ent.El).Wire, Vcd_El) then
                  Alias := Fst_Table.Table (Ent.El).Hand;
                  exit;
               else
                  Ent := Ent.Next;
               end if;
            end loop;
         end;
      end if;

      --  Source (for instances ?)
      if Boolean'(False) then
         declare
            Filename : Ghdl_C_String;
            Line : VhpiIntT;
         begin
            Vhpi_Get_Str (VhpiFileNameP, Sig, Filename);
            Vhpi_Get (VhpiLineNoP, Sig, Line, Err);
            if Filename /= null and then Err = AvhpiErrorOk then
               fstWriterSetSourceStem
                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
            end if;
         end;
      end if;

      --  Extract type name.
      Vhpi_Handle (VhpiSubtype, Sig, Sig_Type, Err);
      if Err /= AvhpiErrorOk then
         Avhpi_Error (Err);
      end if;
      Vhpi_Handle (VhpiTypeMark, Sig_Type, Sig_Type, Err);
      if Err /= AvhpiErrorOk then
         Avhpi_Error (Err);
      end if;
      Vhpi_Get_Str (VhpiNameP, Sig_Type, Type_Name, Type_Name_Len);
      if Type_Name_Len = 0 then
         --  Try with the base type.
         Vhpi_Handle (VhpiBaseType, Sig_Type, Sig_Base_Type, Err);
         if Err /= AvhpiErrorOk then
            Avhpi_Error (Err);
         end if;
         Vhpi_Get_Str (VhpiNameP, Sig_Base_Type, Type_Name, Type_Name_Len);
      end if;
      if Type_Name_Len = 0 then
         Type_C_Name := null;
      else
         if Type_Name_Len >= Type_Name'Last then
            --  Truncate name.
            Type_Name_Len := Type_Name'Last - 1;
         end if;
         Type_Name (Type_Name_Len + 1) := NUL;
         Type_C_Name := To_Ghdl_C_String (Type_Name'Address);
      end if;

      --  Extract name (avoid truncation, append verilog range for arrays).
      Vhpi_Get_Str (VhpiNameP, Sig, Name, Name_Len);
      if Name_Len >= Name'Length
        or else Vcd_El.Irange /= null
      then
         declare
            Name2 : String (1 .. Name_Len + 3 + 2 * 11 + 1);

            procedure Append (N : Ghdl_I32)
            is
               Num : String (1 .. 11);
               Num_First : Natural;
               Num_Len : Natural;
            begin
               Grt.Vstrings.To_String (Num, Num_First, N);
               Num_Len := Num'Last - Num_First + 1;
               Name2 (Name_Len + 1 .. Name_Len + Num_Len) :=
                 Num (Num_First .. Num'Last);
               Name_Len := Name_Len + Num_Len;
            end Append;
         begin
            Vhpi_Get_Str (VhpiNameP, Sig, Name2, Name_Len);
            if Vcd_El.Irange /= null then
               Name2 (Name_Len + 1) := '[';
               Name_Len := Name_Len + 1;
               Append (Vcd_El.Irange.I32.Left);
               Name2 (Name_Len + 1) := ':';
               Name_Len := Name_Len + 1;
               Append (Vcd_El.Irange.I32.Right);
               Name2 (Name_Len + 1) := ']';
               Name_Len := Name_Len + 1;
            end if;
            Name2 (Name_Len + 1) := NUL;
            Name_Len := Name_Len + 1;

            Hand := fstWriterCreateVar2
              (Context, Vt, Dir, Len, To_Ghdl_C_String (Name2'Address), Alias,
               Type_C_Name, FST_SVT_VHDL_SIGNAL, Sdt);
         end;
      else
         Name (Name_Len + 1) := NUL;
         Hand := fstWriterCreateVar2
           (Context, Vt, Dir, Len, To_Ghdl_C_String (Name'Address),
            Alias, Type_C_Name, FST_SVT_VHDL_SIGNAL, Sdt);
      end if;

      --  Do not put aliases in the table.
      if Flag_Aliases and then Interfaces.C."/=" (Alias, Null_fstHandle) then
         return;
      end if;

      Fst_Table.Append (Fst_Sig_Info'(Wire => Vcd_El, Hand => Hand));

      if Flag_Aliases then
         Hash_Tab (H) := new Bucket_Type'(El => Fst_Table.Last,
                                          Next => Hash_Tab (H));
      end if;
   end Fst_Add_Signal;

   procedure Fst_Put_Hierarchy (Inst : VhpiHandleT);

   procedure Fst_Put_Scope (Scope : fstScopeType; Decl : VhpiHandleT)
   is
      Name : String (1 .. 128);
      Name_Len : Integer;
      Err : AvhpiErrorT;
   begin
      --  Source file and line.
      declare
         Filename : Ghdl_C_String;
         Line : VhpiIntT;
         Arch : VhpiHandleT;
      begin
         Vhpi_Get_Str (VhpiFileNameP, Decl, Filename);
         Vhpi_Get (VhpiLineNoP, Decl, Line, Err);
         if Filename /= null and then Err = AvhpiErrorOk then
            if Vhpi_Get_Kind (Decl) /= VhpiCompInstStmtK then
               --  For a block, a generate block: source location.
               fstWriterSetSourceStem
                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
            else
               --  For a component instantiation: instance location
               fstWriterSetSourceInstantiationStem
                 (Context, Filename, Interfaces.C.unsigned (Line), 0);
               --  Request DesignUnit => arch
               Vhpi_Handle (VhpiDesignUnit, Decl, Arch, Err);
               if Err /= AvhpiErrorOk then
                  Avhpi_Error (Err);
               elsif Arch /= Null_Handle then
                  --  Request filename and line.
                  Vhpi_Get_Str (VhpiFileNameP, Arch, Filename);
                  Vhpi_Get (VhpiLineNoP, Arch, Line, Err);
                  if Filename /= null and then Err = AvhpiErrorOk then
                     --  And source location.
                     fstWriterSetSourceStem
                       (Context, Filename, Interfaces.C.unsigned (Line), 0);
                  end if;
               end if;
            end if;
         end if;
      end;

      Vhpi_Get_Str (VhpiNameP, Decl, Name, Name_Len);
      if Name_Len < Name'Last then
         Name (Name_Len + 1) := NUL;
      else
         --  Truncate
         Name (Name'Last) := NUL;
      end if;

      fstWriterSetScope
        (Context, Scope, To_Ghdl_C_String (Name'Address), null);
      Fst_Put_Hierarchy (Decl);
      fstWriterSetUpscope (Context);
   end Fst_Put_Scope;

   procedure Fst_Put_Hierarchy (Inst : VhpiHandleT)
   is
      Decl_It : VhpiHandleT;
      Decl : VhpiHandleT;
      Error : AvhpiErrorT;
   begin
      Vhpi_Iterator (VhpiDecls, Inst, Decl_It, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;

      --  Extract signals.
      loop
         Vhpi_Scan (Decl_It, Decl, Error);
         exit when Error = AvhpiErrorIteratorEnd;
         if Error /= AvhpiErrorOk then
            Avhpi_Error (Error);
            return;
         end if;

         case Vhpi_Get_Kind (Decl) is
            when VhpiPortDeclK
              | VhpiSigDeclK =>
               Fst_Add_Signal (Decl);
            when others =>
               null;
         end case;
      end loop;

      --  Extract sub-scopes.
      Vhpi_Iterator (VhpiInternalRegions, Inst, Decl_It, Error);
      if Error /= AvhpiErrorOk then
         Avhpi_Error (Error);
         return;
      end if;

      loop
         Vhpi_Scan (Decl_It, Decl, Error);
         exit when Error = AvhpiErrorIteratorEnd;
         if Error /= AvhpiErrorOk then
            Avhpi_Error (Error);
            return;
         end if;

         case Vhpi_Get_Kind (Decl) is
            when VhpiIfGenerateK =>
               Fst_Put_Scope (FST_ST_VHDL_IF_GENERATE, Decl);
            when VhpiForGenerateK =>
               Fst_Put_Scope (FST_ST_VHDL_FOR_GENERATE, Decl);
            when  VhpiBlockStmtK =>
               Fst_Put_Scope (FST_ST_VHDL_BLOCK, Decl);
            when VhpiCompInstStmtK =>
               Fst_Put_Scope (FST_ST_VHDL_ARCHITECTURE, Decl);
            when others =>
               null;
         end case;
      end loop;
   end Fst_Put_Hierarchy;

   procedure Fst_Put_Integer32 (Hand : fstHandle; V : Ghdl_U32)
   is
      Str : String (1 .. 32);
      Val : Ghdl_U32;
   begin
      Val := V;
      for I in Str'Range loop
         Str (I) := Character'Val (Character'Pos ('0') + (Val and 1));
         Val := Val / 2;
      end loop;
      fstWriterEmitValueChange (Context, Hand, Str'Address);
   end Fst_Put_Integer32;

   procedure Fst_Put_Var (I : Fst_Index_Type)
   is
      From_Bit : constant array (Ghdl_B1) of Character := "01";
      type Map_Type is array (Ghdl_E8 range 0 .. 8) of Character;
      From_Std : constant Map_Type := "UX01ZWLH-";
      V : Fst_Sig_Info renames Fst_Table.Table (I);
      Len : Ghdl_Index_Type;
      Hand : constant fstHandle := V.Hand;
      Sig : constant Signal_Arr_Ptr := V.Wire.Sigs;
   begin
      if V.Wire.Irange = null then
         Len := 1;
      else
         Len := V.Wire.Irange.I32.Len;
      end if;
      case V.Wire.Val is
         when Vcd_Effective =>
            case V.Wire.Kind is
               when Vcd_Bit
                 | Vcd_Bool
                 | Vcd_Bitvector =>
                  declare
                     Str : Std_String_Uncons (0 .. Len - 1);
                  begin
                     for I in Str'Range loop
                        Str (I) := From_Bit (Sig (I).Value.B1);
                     end loop;
                     fstWriterEmitValueChange (Context, Hand, Str'Address);
                  end;
               when Vcd_Stdlogic
                 | Vcd_Stdlogic_Vector =>
                  declare
                     Str : Std_String_Uncons (0 .. Len - 1);
                  begin
                     for I in Str'Range loop
                        Str (I) := From_Std (Sig (I).Value.E8);
                     end loop;
                     fstWriterEmitValueChange (Context, Hand, Str'Address);
                  end;
               when Vcd_Integer32 =>
                  Fst_Put_Integer32 (Hand, Sig (0).Value.E32);
               when Vcd_Float64 =>
                  null;
               when Vcd_Bad =>
                  null;
            end case;
         when Vcd_Driving =>
            case V.Wire.Kind is
               when Vcd_Bit
                 | Vcd_Bool
                 | Vcd_Bitvector =>
                  declare
                     Str : Std_String_Uncons (0 .. Len - 1);
                  begin
                     for I in Str'Range loop
                        Str (I) := From_Bit (Sig (I).Driving_Value.B1);
                     end loop;
                     fstWriterEmitValueChange (Context, Hand, Str'Address);
                  end;
               when Vcd_Stdlogic
                 | Vcd_Stdlogic_Vector =>
                  declare
                     Str : Std_String_Uncons (0 .. Len - 1);
                  begin
                     for I in Str'Range loop
                        Str (I) := From_Std (Sig (I).Driving_Value.E8);
                     end loop;
                     fstWriterEmitValueChange (Context, Hand, Str'Address);
                  end;
               when Vcd_Integer32 =>
                  Fst_Put_Integer32 (Hand, Sig (0).Driving_Value.E32);
               when Vcd_Float64 =>
                  null;
               when Vcd_Bad =>
                  null;
            end case;
      end case;
   end Fst_Put_Var;

   procedure Fst_Cycle;

   --  Called after elaboration.
   procedure Fst_Start
   is
      Root : VhpiHandleT;
   begin
      --  Do nothing if there is no VCD file to generate.
      if Context = Null_fstContext then
         return;
      end if;

      --  Be sure the RTI of std_ulogic is set.
      Search_Types_RTI;

      if Flag_Aliases then
         Hash_Tab :=
           new Hash_Table (0 .. Ghdl_Index_Type (Sig_Table.Last / 17));
      end if;

      --  Put hierarchy.
      Get_Root_Inst (Root);
      Fst_Put_Hierarchy (Root);

      if Flag_Aliases then
         Free_Hash_Tab;
      end if;

      Register_Cycle_Hook (Fst_Cycle'Access);
   end Fst_Start;

   --  Called before each non delta cycle.
   procedure Fst_Cycle is
   begin
      --  Disp values.
      fstWriterEmitTimeChange (Context, Unsigned_64 (Cycle_Time));

      if Cycle_Time = 0 then
         --  Disp all values.
         for I in Fst_Table.First .. Fst_Table.Last loop
            Fst_Put_Var (I);
         end loop;
      else
         --  Disp only values changed.
         for I in Fst_Table.First .. Fst_Table.Last loop
            if Verilog_Wire_Changed (Fst_Table.Table (I).Wire, Cycle_Time) then
               Fst_Put_Var (I);
            end if;
         end loop;
      end if;
   end Fst_Cycle;

   --  Called at the end of the simulation.
   procedure Fst_End is
   begin
      if Context /= Null_fstContext then
         fstWriterClose (Context);
         Context := Null_fstContext;
      end if;
   end Fst_End;

   Fst_Hooks : aliased constant Hooks_Type :=
     (Option => Fst_Option'Access,
      Help => Fst_Help'Access,
      Init => Fst_Init'Access,
      Start => Fst_Start'Access,
      Finish => Fst_End'Access);

   procedure Register is
   begin
      Register_Hooks (Fst_Hooks'Access);
   end Register;
end Grt.Fst;