diff options
Diffstat (limited to 'src/grt/grt-fst.adb')
| -rw-r--r-- | src/grt/grt-fst.adb | 474 |
1 files changed, 474 insertions, 0 deletions
diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb new file mode 100644 index 000000000..bd7b9a940 --- /dev/null +++ b/src/grt/grt-fst.adb @@ -0,0 +1,474 @@ +-- 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; +pragma Elaborate_All (Grt.Table); + +package body Grt.Fst is + 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; + + procedure Fst_Add_Signal (Sig : VhpiHandleT) + is + Vcd_El : Verilog_Wire_Info; + Vt : fstVarType; + Sdt : fstSupplementalDataType; + Dir : fstVarDir; + Len : Interfaces.C.unsigned; + Name : String (1 .. 128); + Name_Len : Natural; + Hand : fstHandle; + begin + Get_Verilog_Wire (Sig, Vcd_El); + + if Vcd_El.Kind = Vcd_Bad then + -- Not handled. + return; + end if; + + + case Vcd_El.Kind is + when Vcd_Bad => + raise Program_Error; + 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; + + 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), + Null_fstHandle, null, FST_SVT_VHDL_SIGNAL, Sdt); + end; + else + Name (Name_Len) := NUL; + Hand := fstWriterCreateVar2 + (Context, Vt, Dir, Len, To_Ghdl_C_String (Name'Address), + Null_fstHandle, null, FST_SVT_VHDL_SIGNAL, Sdt); + end if; + + Fst_Table.Append (Fst_Sig_Info'(Wire => Vcd_El, Hand => Hand)); + 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; + begin + 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-"; + Sig : Signal_Arr_Ptr; + V : Fst_Sig_Info renames Fst_Table.Table (I); + Len : Ghdl_Index_Type; + Hand : constant fstHandle := V.Hand; + begin + Sig := To_Signal_Arr_Ptr (V.Wire.Addr); + 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; + + -- Put hierarchy. + Get_Root_Inst (Root); + Fst_Put_Hierarchy (Root); + + 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; |