diff options
Diffstat (limited to 'src/translate/grt/grt-waves.adb')
| -rw-r--r-- | src/translate/grt/grt-waves.adb | 1632 |
1 files changed, 0 insertions, 1632 deletions
diff --git a/src/translate/grt/grt-waves.adb b/src/translate/grt/grt-waves.adb deleted file mode 100644 index 63bdb9a..0000000 --- a/src/translate/grt/grt-waves.adb +++ /dev/null @@ -1,1632 +0,0 @@ --- GHDL Run Time (GRT) - wave dumper (GHW) module. --- Copyright (C) 2002 - 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 Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with Interfaces; use Interfaces; -with System.Storage_Elements; -- Work around GNAT bug. -pragma Unreferenced (System.Storage_Elements); -with Grt.Types; use Grt.Types; -with Grt.Avhpi; use Grt.Avhpi; -with Grt.Stdio; use Grt.Stdio; -with Grt.C; use Grt.C; -with Grt.Errors; use Grt.Errors; -with Grt.Astdio; use Grt.Astdio; -with Grt.Hooks; use Grt.Hooks; -with Grt.Table; -with Grt.Avls; use Grt.Avls; -with Grt.Rtis; use Grt.Rtis; -with Grt.Rtis_Addr; use Grt.Rtis_Addr; -with Grt.Rtis_Utils; -with Grt.Rtis_Types; -with Grt.Signals; use Grt.Signals; -with System; use System; -with Grt.Vstrings; use Grt.Vstrings; - -pragma Elaborate_All (Grt.Rtis_Utils); -pragma Elaborate_All (Grt.Table); - -package body Grt.Waves is - -- Waves filename. - Wave_Filename : String_Access := null; - -- Stream corresponding to the GHW filename. - Wave_Stream : FILEs; - - Ghw_Hie_Design : constant Unsigned_8 := 1; - Ghw_Hie_Block : constant Unsigned_8 := 3; - Ghw_Hie_Generate_If : constant Unsigned_8 := 4; - Ghw_Hie_Generate_For : constant Unsigned_8 := 5; - Ghw_Hie_Instance : constant Unsigned_8 := 6; - Ghw_Hie_Package : constant Unsigned_8 := 7; - Ghw_Hie_Process : constant Unsigned_8 := 13; - Ghw_Hie_Generic : constant Unsigned_8 := 14; - Ghw_Hie_Eos : constant Unsigned_8 := 15; -- End of scope. - Ghw_Hie_Signal : constant Unsigned_8 := 16; -- Signal. - Ghw_Hie_Port_In : constant Unsigned_8 := 17; -- Port - Ghw_Hie_Port_Out : constant Unsigned_8 := 18; -- Port - Ghw_Hie_Port_Inout : constant Unsigned_8 := 19; -- Port - Ghw_Hie_Port_Buffer : constant Unsigned_8 := 20; -- Port - Ghw_Hie_Port_Linkage : constant Unsigned_8 := 21; -- Port - - pragma Unreferenced (Ghw_Hie_Design); - pragma Unreferenced (Ghw_Hie_Generic); - - -- Return TRUE if OPT is an option for wave. - function Wave_Option (Opt : String) return Boolean - is - F : constant Natural := Opt'First; - begin - if Opt'Length < 6 or else Opt (F .. F + 5) /= "--wave" then - return False; - end if; - if Opt'Length > 6 and then Opt (F + 6) = '=' then - -- Add an extra NUL character. - Wave_Filename := new String (1 .. Opt'Length - 7 + 1); - Wave_Filename (1 .. Opt'Length - 7) := Opt (F + 7 .. Opt'Last); - Wave_Filename (Wave_Filename'Last) := NUL; - return True; - else - return False; - end if; - end Wave_Option; - - procedure Wave_Help is - begin - Put_Line (" --wave=FILENAME dump signal values into a wave file"); - end Wave_Help; - - procedure Wave_Put (Str : String) - is - R : size_t; - pragma Unreferenced (R); - begin - R := fwrite (Str'Address, Str'Length, 1, Wave_Stream); - end Wave_Put; - - procedure Wave_Putc (C : Character) - is - R : int; - pragma Unreferenced (R); - begin - R := fputc (Character'Pos (C), Wave_Stream); - end Wave_Putc; - - procedure Wave_Newline is - begin - Wave_Putc (Nl); - end Wave_Newline; - - procedure Wave_Put_Byte (B : Unsigned_8) - is - V : Unsigned_8 := B; - R : size_t; - pragma Unreferenced (R); - begin - R := fwrite (V'Address, 1, 1, Wave_Stream); - end Wave_Put_Byte; - - procedure Wave_Put_ULEB128 (Val : Ghdl_E32) - is - V : Ghdl_E32; - R : Ghdl_E32; - begin - V := Val; - loop - R := V mod 128; - V := V / 128; - if V = 0 then - Wave_Put_Byte (Unsigned_8 (R)); - exit; - else - Wave_Put_Byte (Unsigned_8 (128 + R)); - end if; - end loop; - end Wave_Put_ULEB128; - - procedure Wave_Put_SLEB128 (Val : Ghdl_I32) - is - function To_Ghdl_U32 is new Ada.Unchecked_Conversion - (Ghdl_I32, Ghdl_U32); - V : Ghdl_U32 := To_Ghdl_U32 (Val); - --- function Shift_Right_Arithmetic (Value : Ghdl_U32; Amount : Natural) --- return Ghdl_U32; --- pragma Import (Intrinsic, Shift_Right_Arithmetic); - R : Unsigned_8; - begin - loop - R := Unsigned_8 (V mod 128); - V := Shift_Right_Arithmetic (V, 7); - if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) - then - Wave_Put_Byte (R); - exit; - else - Wave_Put_Byte (R or 16#80#); - end if; - end loop; - end Wave_Put_SLEB128; - - procedure Wave_Put_LSLEB128 (Val : Ghdl_I64) - is - function To_Ghdl_U64 is new Ada.Unchecked_Conversion - (Ghdl_I64, Ghdl_U64); - V : Ghdl_U64 := To_Ghdl_U64 (Val); - - R : Unsigned_8; - begin - loop - R := Unsigned_8 (V mod 128); - V := Shift_Right_Arithmetic (V, 7); - if (V = 0 and (R and 16#40#) = 0) or (V = -1 and (R and 16#40#) /= 0) - then - Wave_Put_Byte (R); - exit; - else - Wave_Put_Byte (R or 16#80#); - end if; - end loop; - end Wave_Put_LSLEB128; - - procedure Wave_Put_I32 (Val : Ghdl_I32) - is - V : Ghdl_I32 := Val; - R : size_t; - pragma Unreferenced (R); - begin - R := fwrite (V'Address, 4, 1, Wave_Stream); - end Wave_Put_I32; - - procedure Wave_Put_I64 (Val : Ghdl_I64) - is - V : Ghdl_I64 := Val; - R : size_t; - pragma Unreferenced (R); - begin - R := fwrite (V'Address, 8, 1, Wave_Stream); - end Wave_Put_I64; - - procedure Wave_Put_F64 (F64 : Ghdl_F64) - is - V : Ghdl_F64 := F64; - R : size_t; - pragma Unreferenced (R); - begin - R := fwrite (V'Address, Ghdl_F64'Size / Storage_Unit, 1, Wave_Stream); - end Wave_Put_F64; - - procedure Wave_Puts (Str : Ghdl_C_String) is - begin - Put (Wave_Stream, Str); - end Wave_Puts; - - procedure Write_Value (Value : Value_Union; Mode : Mode_Type) is - begin - case Mode is - when Mode_B1 => - Wave_Put_Byte (Ghdl_B1'Pos (Value.B1)); - when Mode_E8 => - Wave_Put_Byte (Ghdl_E8'Pos (Value.E8)); - when Mode_E32 => - Wave_Put_ULEB128 (Value.E32); - when Mode_I32 => - Wave_Put_SLEB128 (Value.I32); - when Mode_I64 => - Wave_Put_LSLEB128 (Value.I64); - when Mode_F64 => - Wave_Put_F64 (Value.F64); - end case; - end Write_Value; - - subtype Section_Name is String (1 .. 4); - type Header_Type is record - Name : Section_Name; - Pos : long; - end record; - - package Section_Table is new Grt.Table - (Table_Component_Type => Header_Type, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 16); - - -- Create a new section. - -- Write the header in the file. - -- Save the location for the directory. - procedure Wave_Section (Name : Section_Name) is - begin - Section_Table.Append (Header_Type'(Name => Name, - Pos => ftell (Wave_Stream))); - Wave_Put (Name); - end Wave_Section; - - procedure Wave_Write_Size_Order is - begin - -- Byte order, 1 byte. - -- 0: bad, 1 : little-endian, 2 : big endian. - declare - type Byte_Arr is array (0 .. 3) of Unsigned_8; - function To_Byte_Arr is new Ada.Unchecked_Conversion - (Source => Unsigned_32, Target => Byte_Arr); - B4 : constant Byte_Arr := To_Byte_Arr (16#11_22_33_44#); - V : Unsigned_8; - begin - if B4 (0) = 16#11# then - -- Big endian. - V := 2; - elsif B4 (0) = 16#44# then - -- Little endian. - V := 1; - else - -- Unknown endian. - V := 0; - end if; - Wave_Put_Byte (V); - end; - -- Word size, 1 byte. - Wave_Put_Byte (Integer'Size / 8); - -- File offset size, 1 byte - Wave_Put_Byte (1); - -- Unused, must be zero (MBZ). - Wave_Put_Byte (0); - end Wave_Write_Size_Order; - - procedure Wave_Write_Directory - is - Pos : long; - begin - Pos := ftell (Wave_Stream); - Wave_Section ("DIR" & NUL); - Wave_Write_Size_Order; - Wave_Put_I32 (Ghdl_I32 (Section_Table.Last)); - for I in Section_Table.First .. Section_Table.Last loop - Wave_Put (Section_Table.Table (I).Name); - Wave_Put_I32 (Ghdl_I32 (Section_Table.Table (I).Pos)); - end loop; - Wave_Put ("EOD" & NUL); - - Wave_Section ("TAI" & NUL); - Wave_Write_Size_Order; - Wave_Put_I32 (Ghdl_I32 (Pos)); - end Wave_Write_Directory; - - -- Called before elaboration. - procedure Wave_Init - is - Mode : constant String := "wb" & NUL; - begin - if Wave_Filename = null then - Wave_Stream := NULL_Stream; - return; - end if; - if Wave_Filename.all = "-" & NUL then - Wave_Stream := stdout; - else - Wave_Stream := fopen (Wave_Filename.all'Address, Mode'Address); - if Wave_Stream = NULL_Stream then - Error_C ("cannot open "); - Error_E (Wave_Filename (Wave_Filename'First - .. Wave_Filename'Last - 1)); - return; - end if; - end if; - end Wave_Init; - - procedure Write_File_Header - is - begin - -- Magic, 9 bytes. - Wave_Put ("GHDLwave" & Nl); - -- Header length. - Wave_Put_Byte (16); - -- Version-major, 1 byte. - Wave_Put_Byte (0); - -- Version-minor, 1 byte. - Wave_Put_Byte (1); - - Wave_Write_Size_Order; - end Write_File_Header; - - procedure Avhpi_Error (Err : AvhpiErrorT) - is - pragma Unreferenced (Err); - begin - Put_Line ("Waves.Avhpi_Error!"); - null; - end Avhpi_Error; - - package Str_Table is new Grt.Table - (Table_Component_Type => Ghdl_C_String, - Table_Index_Type => AVL_Value, - Table_Low_Bound => 1, - Table_Initial => 16); - - package Str_AVL is new Grt.Table - (Table_Component_Type => AVL_Node, - Table_Index_Type => AVL_Nid, - Table_Low_Bound => AVL_Root, - Table_Initial => 16); - - Strings_Len : Natural := 0; - - function Str_Compare (L, R : AVL_Value) return Integer - is - Ls, Rs : Ghdl_C_String; - begin - Ls := Str_Table.Table (L); - Rs := Str_Table.Table (R); - if L = R then - return 0; - end if; - return Strcmp (Ls, Rs); - end Str_Compare; - - procedure Disp_Str_Avl (N : AVL_Nid) is - begin - Put (stdout, "node: "); - Put_I32 (stdout, Ghdl_I32 (N)); - New_Line (stdout); - Put (stdout, " left: "); - Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Left)); - New_Line (stdout); - Put (stdout, " right: "); - Put_I32 (stdout, Ghdl_I32 (Str_AVL.Table (N).Right)); - New_Line (stdout); - Put (stdout, " height: "); - Put_I32 (stdout, Str_AVL.Table (N).Height); - New_Line (stdout); - Put (stdout, " str: "); - --Put (stdout, Str_AVL.Table (N).Val); - New_Line (stdout); - end Disp_Str_Avl; - - pragma Unreferenced (Disp_Str_Avl); - - function Create_Str_Index (Str : Ghdl_C_String) return AVL_Value - is - Res : AVL_Nid; - begin - Str_Table.Append (Str); - Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, - Left | Right => AVL_Nil, - Height => 1)); - Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), - Str_Compare'Access, - Str_AVL.Last, Res); - if Res /= Str_AVL.Last then - Str_AVL.Decrement_Last; - Str_Table.Decrement_Last; - else - Strings_Len := Strings_Len + strlen (Str); - end if; - return Str_AVL.Table (Res).Val; - end Create_Str_Index; - - pragma Unreferenced (Create_Str_Index); - - procedure Create_String_Id (Str : Ghdl_C_String) - is - Res : AVL_Nid; - begin - if Str = null then - return; - end if; - Str_Table.Append (Str); - Str_AVL.Append (AVL_Node'(Val => Str_Table.Last, - Left | Right => AVL_Nil, - Height => 1)); - Get_Node (AVL_Tree (Str_AVL.Table (Str_AVL.First .. Str_AVL.Last)), - Str_Compare'Access, - Str_AVL.Last, Res); - if Res /= Str_AVL.Last then - Str_AVL.Decrement_Last; - Str_Table.Decrement_Last; - else - Strings_Len := Strings_Len + strlen (Str); - end if; - end Create_String_Id; - - function Get_String (Str : Ghdl_C_String) return AVL_Value - is - H, L, M : AVL_Value; - Diff : Integer; - begin - L := Str_Table.First; - H := Str_Table.Last; - loop - M := (L + H) / 2; - Diff := Strcmp (Str, Str_Table.Table (M)); - if Diff = 0 then - return M; - elsif Diff < 0 then - H := M - 1; - else - L := M + 1; - end if; - exit when L > H; - end loop; - return 0; - end Get_String; - - procedure Write_String_Id (Str : Ghdl_C_String) is - begin - if Str = null then - Wave_Put_Byte (0); - else - Wave_Put_ULEB128 (Ghdl_E32 (Get_String (Str))); - end if; - end Write_String_Id; - - type Type_Node is record - Type_Rti : Ghdl_Rti_Access; - Context : Rti_Context; - end record; - - package Types_Table is new Grt.Table - (Table_Component_Type => Type_Node, - Table_Index_Type => AVL_Value, - Table_Low_Bound => 1, - Table_Initial => 16); - - package Types_AVL is new Grt.Table - (Table_Component_Type => AVL_Node, - Table_Index_Type => AVL_Nid, - Table_Low_Bound => AVL_Root, - Table_Initial => 16); - - function Type_Compare (L, R : AVL_Value) return Integer - is - function To_Ia is new - Ada.Unchecked_Conversion (Ghdl_Rti_Access, Integer_Address); - - function "<" (L, R : Ghdl_Rti_Access) return Boolean is - begin - return To_Ia (L) < To_Ia (R); - end "<"; - - Ls : Type_Node renames Types_Table.Table (L); - Rs : Type_Node renames Types_Table.Table (R); - begin - if Ls.Type_Rti /= Rs.Type_Rti then - if Ls.Type_Rti < Rs.Type_Rti then - return -1; - else - return 1; - end if; - end if; - if Ls.Context.Block /= Rs.Context.Block then - if Ls.Context.Block < Rs.Context.Block then - return -1; - else - return +1; - end if; - end if; - if Ls.Context.Base /= Rs.Context.Base then - if Ls.Context.Base < Rs.Context.Base then - return -1; - else - return +1; - end if; - end if; - return 0; - end Type_Compare; - - -- Try to find type (RTI, CTXT) in the types_AVL table. - -- The first step is to canonicalize CTXT, so that it is the CTXT of - -- the type (and not a sub-scope of it). - procedure Find_Type (Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - N_Ctxt : out Rti_Context; - Id : out AVL_Nid) - is - Depth : Ghdl_Rti_Depth; - begin - case Rti.Kind is - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 => - N_Ctxt := Null_Context; - when Ghdl_Rtik_Port - | Ghdl_Rtik_Signal => - N_Ctxt := Ctxt; - when others => - -- Compute the canonical context. - if Rti.Max_Depth < Rti.Depth then - Internal_Error ("grt.waves.find_type"); - end if; - Depth := Rti.Max_Depth; - if Depth = 0 or else Ctxt.Block = null then - N_Ctxt := Null_Context; - else - N_Ctxt := Ctxt; - while N_Ctxt.Block.Depth > Depth loop - N_Ctxt := Get_Parent_Context (N_Ctxt); - end loop; - end if; - end case; - - -- If the type is already known, return now. - -- Otherwise, ID is set to AVL_Nil. - Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => N_Ctxt)); - Id := Find_Node - (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), - Type_Compare'Access, - Types_Table.Last); - Types_Table.Decrement_Last; - end Find_Type; - - procedure Write_Type_Id (Tid : AVL_Nid) is - begin - Wave_Put_ULEB128 (Ghdl_E32 (Types_AVL.Table (Tid).Val)); - end Write_Type_Id; - - procedure Write_Type_Id (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) - is - N_Ctxt : Rti_Context; - Res : AVL_Nid; - begin - Find_Type (Rti, Ctxt, N_Ctxt, Res); - if Res = AVL_Nil then - -- raise Program_Error; - Internal_Error ("write_type_id"); - end if; - Write_Type_Id (Res); - end Write_Type_Id; - - procedure Add_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) - is - Res : AVL_Nid; - begin - -- Then, create the type. - Types_Table.Append (Type_Node'(Type_Rti => Rti, Context => Ctxt)); - Types_AVL.Append (AVL_Node'(Val => Types_Table.Last, - Left | Right => AVL_Nil, - Height => 1)); - - Get_Node - (AVL_Tree (Types_AVL.Table (Types_AVL.First .. Types_AVL.Last)), - Type_Compare'Access, - Types_AVL.Last, Res); - if Res /= Types_AVL.Last then - --raise Program_Error; - Internal_Error ("wave.create_type(2)"); - end if; - end Add_Type; - - procedure Create_Type (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) - is - N_Ctxt : Rti_Context; - Res : AVL_Nid; - begin - Find_Type (Rti, Ctxt, N_Ctxt, Res); - if Res /= AVL_Nil then - return; - end if; - - -- First, create all the types it depends on. - case Rti.Kind is - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 => - declare - Enum : Ghdl_Rtin_Type_Enum_Acc; - begin - Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); - Create_String_Id (Enum.Name); - for I in 1 .. Enum.Nbr loop - Create_String_Id (Enum.Names (I - 1)); - end loop; - end; - when Ghdl_Rtik_Subtype_Array => - declare - Arr : Ghdl_Rtin_Subtype_Array_Acc; - B_Ctxt : Rti_Context; - begin - Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Create_String_Id (Arr.Name); - if Rti_Complex_Type (Rti) then - B_Ctxt := Ctxt; - else - B_Ctxt := N_Ctxt; - end if; - Create_Type (To_Ghdl_Rti_Access (Arr.Basetype), B_Ctxt); - end; - when Ghdl_Rtik_Type_Array => - declare - Arr : Ghdl_Rtin_Type_Array_Acc; - begin - Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); - Create_String_Id (Arr.Name); - Create_Type (Arr.Element, N_Ctxt); - for I in 1 .. Arr.Nbr_Dim loop - Create_Type (Arr.Indexes (I - 1), N_Ctxt); - end loop; - end; - when Ghdl_Rtik_Subtype_Scalar => - declare - Sub : Ghdl_Rtin_Subtype_Scalar_Acc; - begin - Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); - Create_String_Id (Sub.Name); - Create_Type (Sub.Basetype, N_Ctxt); - end; - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_I64 - | Ghdl_Rtik_Type_F64 => - declare - Base : Ghdl_Rtin_Type_Scalar_Acc; - begin - Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); - Create_String_Id (Base.Name); - end; - when Ghdl_Rtik_Type_P32 - | Ghdl_Rtik_Type_P64 => - declare - Base : Ghdl_Rtin_Type_Physical_Acc; - Unit_Name : Ghdl_C_String; - begin - Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); - Create_String_Id (Base.Name); - for I in 1 .. Base.Nbr loop - Unit_Name := - Rtis_Utils.Get_Physical_Unit_Name (Base.Units (I - 1)); - Create_String_Id (Unit_Name); - end loop; - end; - when Ghdl_Rtik_Type_Record => - declare - Rec : Ghdl_Rtin_Type_Record_Acc; - El : Ghdl_Rtin_Element_Acc; - begin - Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); - Create_String_Id (Rec.Name); - for I in 1 .. Rec.Nbrel loop - El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); - Create_String_Id (El.Name); - Create_Type (El.Eltype, N_Ctxt); - end loop; - end; - when others => - Internal_Error ("wave.create_type"); --- Internal_Error ("wave.create_type: does not handle " & --- Ghdl_Rtik'Image (Rti.Kind)); - end case; - - -- Then, create the type. - Add_Type (Rti, N_Ctxt); - end Create_Type; - - procedure Create_Object_Type (Obj : VhpiHandleT) - is - Obj_Type : VhpiHandleT; - Error : AvhpiErrorT; - Rti : Ghdl_Rti_Access; - begin - -- Extract type of the signal. - Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - Rti := Avhpi_Get_Rti (Obj_Type); - Create_Type (Rti, Avhpi_Get_Context (Obj_Type)); - - -- The the signal type is an unconstrained array, also put the object - -- in the type AVL. - -- The real type will be written to the file. - if Rti.Kind = Ghdl_Rtik_Type_Array then - Add_Type (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); - end if; - end Create_Object_Type; - - procedure Write_Object_Type (Obj : VhpiHandleT) - is - Obj_Type : VhpiHandleT; - Error : AvhpiErrorT; - Rti : Ghdl_Rti_Access; - begin - -- Extract type of the signal. - Vhpi_Handle (VhpiSubtype, Obj, Obj_Type, Error); - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - Rti := Avhpi_Get_Rti (Obj_Type); - if Rti.Kind = Ghdl_Rtik_Type_Array then - Write_Type_Id (Avhpi_Get_Rti (Obj), Avhpi_Get_Context (Obj)); - else - Write_Type_Id (Rti, Avhpi_Get_Context (Obj_Type)); - end if; - end Write_Object_Type; - - procedure Create_Generate_Type (Gen : VhpiHandleT) - is - Iterator : VhpiHandleT; - Error : AvhpiErrorT; - begin - -- Extract the iterator. - Vhpi_Handle (VhpiIterScheme, Gen, Iterator, Error); - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - Create_Object_Type (Iterator); - end Create_Generate_Type; - - procedure Write_Generate_Type_And_Value (Gen : VhpiHandleT) - is - Iter : VhpiHandleT; - Iter_Type : VhpiHandleT; - Error : AvhpiErrorT; - Addr : Address; - Mode : Mode_Type; - Rti : Ghdl_Rti_Access; - begin - -- Extract the iterator. - Vhpi_Handle (VhpiIterScheme, Gen, Iter, Error); - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - Write_Object_Type (Iter); - - Vhpi_Handle (VhpiSubtype, Iter, Iter_Type, Error); - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - Rti := Avhpi_Get_Rti (Iter_Type); - Addr := Avhpi_Get_Address (Iter); - - case Get_Base_Type (Rti).Kind is - when Ghdl_Rtik_Type_B1 => - Mode := Mode_B1; - when Ghdl_Rtik_Type_E8 => - Mode := Mode_E8; - when Ghdl_Rtik_Type_E32 => - Mode := Mode_E32; - when Ghdl_Rtik_Type_I32 => - Mode := Mode_I32; - when Ghdl_Rtik_Type_I64 => - Mode := Mode_I64; - when Ghdl_Rtik_Type_F64 => - Mode := Mode_F64; - when others => - Internal_Error ("bad iterator type"); - end case; - Write_Value (To_Ghdl_Value_Ptr (Addr).all, Mode); - end Write_Generate_Type_And_Value; - - type Step_Type is (Step_Name, Step_Hierarchy); - - Nbr_Scopes : Natural := 0; - Nbr_Scope_Signals : Natural := 0; - Nbr_Dumped_Signals : Natural := 0; - - -- This is only valid during write_hierarchy. - function Get_Signal_Number (Sig : Ghdl_Signal_Ptr) return Natural - is - function To_Integer_Address is new Ada.Unchecked_Conversion - (Ghdl_Signal_Ptr, Integer_Address); - begin - return Natural (To_Integer_Address (Sig.Alink)); - end Get_Signal_Number; - - procedure Write_Signal_Number (Val_Addr : Address; - Val_Name : Vstring; - Val_Type : Ghdl_Rti_Access; - Param_Type : Natural) - is - pragma Unreferenced (Val_Name); - pragma Unreferenced (Val_Type); - pragma Unreferenced (Param_Type); - - Num : Natural; - - function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion - (Source => Integer_Address, Target => Ghdl_Signal_Ptr); - Sig : Ghdl_Signal_Ptr; - begin - -- Convert to signal. - Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all); - - -- Get signal number. - Num := Get_Signal_Number (Sig); - - -- If the signal number is 0, then assign a valid signal number. - if Num = 0 then - Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1; - Sig.Alink := To_Ghdl_Signal_Ptr - (Integer_Address (Nbr_Dumped_Signals)); - Num := Nbr_Dumped_Signals; - end if; - - -- Do the real job: write the signal number. - Wave_Put_ULEB128 (Ghdl_E32 (Num)); - end Write_Signal_Number; - - procedure Foreach_Scalar_Signal_Number is new - Grt.Rtis_Utils.Foreach_Scalar (Param_Type => Natural, - Process => Write_Signal_Number); - - procedure Write_Signal_Numbers (Decl : VhpiHandleT) - is - Ctxt : Rti_Context; - Sig : Ghdl_Rtin_Object_Acc; - begin - Ctxt := Avhpi_Get_Context (Decl); - Sig := To_Ghdl_Rtin_Object_Acc (Avhpi_Get_Rti (Decl)); - Foreach_Scalar_Signal_Number - (Ctxt, Sig.Obj_Type, - Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True, 0); - end Write_Signal_Numbers; - - procedure Write_Hierarchy_El (Decl : VhpiHandleT) - is - Mode2hie : constant array (VhpiModeT) of Unsigned_8 := - (VhpiErrorMode => Ghw_Hie_Signal, - VhpiInMode => Ghw_Hie_Port_In, - VhpiOutMode => Ghw_Hie_Port_Out, - VhpiInoutMode => Ghw_Hie_Port_Inout, - VhpiBufferMode => Ghw_Hie_Port_Buffer, - VhpiLinkageMode => Ghw_Hie_Port_Linkage); - V : Unsigned_8; - begin - case Vhpi_Get_Kind (Decl) is - when VhpiPortDeclK => - V := Mode2hie (Vhpi_Get_Mode (Decl)); - when VhpiSigDeclK => - V := Ghw_Hie_Signal; - when VhpiForGenerateK => - V := Ghw_Hie_Generate_For; - when VhpiIfGenerateK => - V := Ghw_Hie_Generate_If; - when VhpiBlockStmtK => - V := Ghw_Hie_Block; - when VhpiCompInstStmtK => - V := Ghw_Hie_Instance; - when VhpiProcessStmtK => - V := Ghw_Hie_Process; - when VhpiPackInstK => - V := Ghw_Hie_Package; - when VhpiRootInstK => - V := Ghw_Hie_Instance; - when others => - --raise Program_Error; - Internal_Error ("write_hierarchy_el"); - end case; - Wave_Put_Byte (V); - Write_String_Id (Avhpi_Get_Base_Name (Decl)); - case Vhpi_Get_Kind (Decl) is - when VhpiPortDeclK - | VhpiSigDeclK => - Write_Object_Type (Decl); - Write_Signal_Numbers (Decl); - when VhpiForGenerateK => - Write_Generate_Type_And_Value (Decl); - when others => - null; - end case; - end Write_Hierarchy_El; - - -- Create a hierarchy block. - procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type); - - procedure Wave_Put_Hierarchy_1 (Inst : VhpiHandleT; Step : Step_Type) - 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 => - case Step is - when Step_Name => - Create_String_Id (Avhpi_Get_Base_Name (Decl)); - Nbr_Scope_Signals := Nbr_Scope_Signals + 1; - Create_Object_Type (Decl); - when Step_Hierarchy => - Write_Hierarchy_El (Decl); - end case; - --Wave_Put_Name (Decl); - --Wave_Newline; - when others => - null; - end case; - end loop; - - -- No sub-scopes for packages. - if Vhpi_Get_Kind (Inst) = VhpiPackInstK then - return; - end if; - - -- 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; - - Nbr_Scopes := Nbr_Scopes + 1; - - case Vhpi_Get_Kind (Decl) is - when VhpiIfGenerateK - | VhpiForGenerateK - | VhpiBlockStmtK - | VhpiCompInstStmtK => - Wave_Put_Hierarchy_Block (Decl, Step); - when VhpiProcessStmtK => - case Step is - when Step_Name => - Create_String_Id (Avhpi_Get_Base_Name (Decl)); - when Step_Hierarchy => - Write_Hierarchy_El (Decl); - end case; - when others => - Internal_Error ("wave_put_hierarchy_1"); --- Wave_Put ("unknown "); --- Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl))); --- Wave_Newline; - end case; - end loop; - end Wave_Put_Hierarchy_1; - - procedure Wave_Put_Hierarchy_Block (Inst : VhpiHandleT; Step : Step_Type) - is - begin - case Step is - when Step_Name => - Create_String_Id (Avhpi_Get_Base_Name (Inst)); - if Vhpi_Get_Kind (Inst) = VhpiForGenerateK then - Create_Generate_Type (Inst); - end if; - when Step_Hierarchy => - Write_Hierarchy_El (Inst); - end case; - - Wave_Put_Hierarchy_1 (Inst, Step); - - if Step = Step_Hierarchy then - Wave_Put_Byte (Ghw_Hie_Eos); - end if; - end Wave_Put_Hierarchy_Block; - - procedure Wave_Put_Hierarchy (Root : VhpiHandleT; Step : Step_Type) - is - Pack_It : VhpiHandleT; - Pack : VhpiHandleT; - Error : AvhpiErrorT; - begin - -- First packages. - Get_Package_Inst (Pack_It); - loop - Vhpi_Scan (Pack_It, Pack, Error); - exit when Error = AvhpiErrorIteratorEnd; - if Error /= AvhpiErrorOk then - Avhpi_Error (Error); - return; - end if; - - Wave_Put_Hierarchy_Block (Pack, Step); - end loop; - - -- Then top entity. - Wave_Put_Hierarchy_Block (Root, Step); - end Wave_Put_Hierarchy; - - procedure Disp_Str_AVL (Str : AVL_Nid; Indent : Natural) - is - begin - if Str = AVL_Nil then - return; - end if; - Disp_Str_AVL (Str_AVL.Table (Str).Left, Indent + 1); - for I in 1 .. Indent loop - Wave_Putc (' '); - end loop; - Wave_Puts (Str_Table.Table (Str_AVL.Table (Str).Val)); --- Wave_Putc ('('); --- Put_I32 (Wave_Stream, Ghdl_I32 (Str)); --- Wave_Putc (')'); --- Put_I32 (Wave_Stream, Get_Height (Str)); - Wave_Newline; - Disp_Str_AVL (Str_AVL.Table (Str).Right, Indent + 1); - end Disp_Str_AVL; - - procedure Write_Strings - is - begin --- Wave_Put ("AVL height: "); --- Put_I32 (Wave_Stream, Ghdl_I32 (Check_AVL (Str_Root))); --- Wave_Newline; - Wave_Put ("strings length: "); - Put_I32 (Wave_Stream, Ghdl_I32 (Strings_Len)); - Wave_Newline; - Disp_Str_AVL (AVL_Root, 0); - fflush (Wave_Stream); - end Write_Strings; - - pragma Unreferenced (Write_Strings); - - procedure Freeze_Strings - is - type Str_Table1_Type is array (1 .. Str_Table.Last) of Ghdl_C_String; - type Str_Table1_Acc is access Str_Table1_Type; - Idx : AVL_Value; - Table1 : Str_Table1_Acc; - - procedure Free is new Ada.Unchecked_Deallocation - (Str_Table1_Type, Str_Table1_Acc); - - procedure Store_Strings (N : AVL_Nid) is - begin - if N = AVL_Nil then - return; - end if; - Store_Strings (Str_AVL.Table (N).Left); - Table1 (Idx) := Str_Table.Table (Str_AVL.Table (N).Val); - Idx := Idx + 1; - Store_Strings (Str_AVL.Table (N).Right); - end Store_Strings; - begin - Table1 := new Str_Table1_Type; - Idx := 1; - Store_Strings (AVL_Root); - Str_Table.Release; - Str_AVL.Free; - for I in Table1.all'Range loop - Str_Table.Table (I) := Table1 (I); - end loop; - Free (Table1); - end Freeze_Strings; - - procedure Write_Strings_Compress - is - Last : Ghdl_C_String; - V : Ghdl_C_String; - L : Natural; - L1 : Natural; - begin - Wave_Section ("STR" & NUL); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_I32 (Ghdl_I32 (Str_Table.Last)); - Wave_Put_I32 (Ghdl_I32 (Strings_Len)); - for I in Str_Table.First .. Str_Table.Last loop - V := Str_Table.Table (I); - if I = Str_Table.First then - L := 1; - else - Last := Str_Table.Table (I - 1); - - for I in Positive loop - if V (I) /= Last (I) then - L := I; - exit; - end if; - end loop; - L1 := L - 1; - loop - if L1 >= 32 then - Wave_Put_Byte (Unsigned_8 (L1 mod 32) + 16#80#); - else - Wave_Put_Byte (Unsigned_8 (L1 mod 32)); - end if; - L1 := L1 / 32; - exit when L1 = 0; - end loop; - end if; - - if Boolean'(False) then - Put ("string "); - Put_I32 (stdout, Ghdl_I32 (I)); - Put (": "); - Put (V); - New_Line; - end if; - - loop - exit when V (L) = NUL; - Wave_Putc (V (L)); - L := L + 1; - end loop; - end loop; - -- Last string length. - Wave_Put_Byte (0); - -- End marker. - Wave_Put ("EOS" & NUL); - end Write_Strings_Compress; - - procedure Write_Range (Rti : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) - is - Kind : Ghdl_Rtik; - begin - Kind := Rti.Kind; - if Kind = Ghdl_Rtik_Subtype_Scalar then - Kind := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype.Kind; - end if; - case Kind is - when Ghdl_Rtik_Type_B1 => - Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) - + Ghdl_Dir_Type'Pos (Rng.B1.Dir) * 16#80#); - Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Left)); - Wave_Put_Byte (Ghdl_B1'Pos (Rng.B1.Right)); - when Ghdl_Rtik_Type_E8 => - Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) - + Ghdl_Dir_Type'Pos (Rng.E8.Dir) * 16#80#); - Wave_Put_Byte (Unsigned_8 (Rng.E8.Left)); - Wave_Put_Byte (Unsigned_8 (Rng.E8.Right)); - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_P32 => - Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) - + Ghdl_Dir_Type'Pos (Rng.I32.Dir) * 16#80#); - Wave_Put_SLEB128 (Rng.I32.Left); - Wave_Put_SLEB128 (Rng.I32.Right); - when Ghdl_Rtik_Type_P64 - | Ghdl_Rtik_Type_I64 => - Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) - + Ghdl_Dir_Type'Pos (Rng.P64.Dir) * 16#80#); - Wave_Put_LSLEB128 (Rng.P64.Left); - Wave_Put_LSLEB128 (Rng.P64.Right); - when Ghdl_Rtik_Type_F64 => - Wave_Put_Byte (Ghdl_Rtik'Pos (Kind) - + Ghdl_Dir_Type'Pos (Rng.F64.Dir) * 16#80#); - Wave_Put_F64 (Rng.F64.Left); - Wave_Put_F64 (Rng.F64.Right); - when others => - Internal_Error ("waves.write_range: unhandled kind"); - --Internal_Error ("waves.write_range: unhandled kind " - -- & Ghdl_Rtik'Image (Kind)); - end case; - end Write_Range; - - procedure Write_Types - is - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - begin - Wave_Section ("TYP" & NUL); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_I32 (Ghdl_I32 (Types_Table.Last)); - for I in Types_Table.First .. Types_Table.Last loop - Rti := Types_Table.Table (I).Type_Rti; - Ctxt := Types_Table.Table (I).Context; - - if Rti.Kind = Ghdl_Rtik_Signal or Rti.Kind = Ghdl_Rtik_Port then - declare - Obj_Rti : constant Ghdl_Rtin_Object_Acc := - To_Ghdl_Rtin_Object_Acc (Rti); - Arr : constant Ghdl_Rtin_Type_Array_Acc := - To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type); - Addr : Ghdl_Uc_Array_Acc; - begin - Wave_Put_Byte (Ghdl_Rtik'Pos (Ghdl_Rtik_Subtype_Array)); - Write_String_Id (null); - Write_Type_Id (Obj_Rti.Obj_Type, Ctxt); - Addr := To_Ghdl_Uc_Array_Acc - (Loc_To_Addr (Rti.Depth, Obj_Rti.Loc, Ctxt)); - declare - Rngs : Ghdl_Range_Array (0 .. Arr.Nbr_Dim - 1); - begin - Bound_To_Range (Addr.Bounds, Arr, Rngs); - for I in Rngs'Range loop - Write_Range (Arr.Indexes (I), Rngs (I)); - end loop; - end; - end; - else - -- Kind. - Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind)); - case Rti.Kind is - when Ghdl_Rtik_Type_B1 - | Ghdl_Rtik_Type_E8 => - declare - Enum : Ghdl_Rtin_Type_Enum_Acc; - begin - Enum := To_Ghdl_Rtin_Type_Enum_Acc (Rti); - Write_String_Id (Enum.Name); - Wave_Put_ULEB128 (Ghdl_E32 (Enum.Nbr)); - for I in 1 .. Enum.Nbr loop - Write_String_Id (Enum.Names (I - 1)); - end loop; - end; - when Ghdl_Rtik_Subtype_Array => - declare - Arr : Ghdl_Rtin_Subtype_Array_Acc; - begin - Arr := To_Ghdl_Rtin_Subtype_Array_Acc (Rti); - Write_String_Id (Arr.Name); - Write_Type_Id (To_Ghdl_Rti_Access (Arr.Basetype), Ctxt); - declare - Rngs : Ghdl_Range_Array - (0 .. Arr.Basetype.Nbr_Dim - 1); - begin - Bound_To_Range - (Loc_To_Addr (Rti.Depth, Arr.Bounds, Ctxt), - Arr.Basetype, Rngs); - for I in Rngs'Range loop - Write_Range (Arr.Basetype.Indexes (I), Rngs (I)); - end loop; - end; - end; - when Ghdl_Rtik_Type_Array => - declare - Arr : Ghdl_Rtin_Type_Array_Acc; - begin - Arr := To_Ghdl_Rtin_Type_Array_Acc (Rti); - Write_String_Id (Arr.Name); - Write_Type_Id (Arr.Element, Ctxt); - Wave_Put_ULEB128 (Ghdl_E32 (Arr.Nbr_Dim)); - for I in 1 .. Arr.Nbr_Dim loop - Write_Type_Id (Arr.Indexes (I - 1), Ctxt); - end loop; - end; - when Ghdl_Rtik_Type_Record => - declare - Rec : Ghdl_Rtin_Type_Record_Acc; - El : Ghdl_Rtin_Element_Acc; - begin - Rec := To_Ghdl_Rtin_Type_Record_Acc (Rti); - Write_String_Id (Rec.Name); - Wave_Put_ULEB128 (Ghdl_E32 (Rec.Nbrel)); - for I in 1 .. Rec.Nbrel loop - El := To_Ghdl_Rtin_Element_Acc (Rec.Elements (I - 1)); - Write_String_Id (El.Name); - Write_Type_Id (El.Eltype, Ctxt); - end loop; - end; - when Ghdl_Rtik_Subtype_Scalar => - declare - Sub : Ghdl_Rtin_Subtype_Scalar_Acc; - begin - Sub := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti); - Write_String_Id (Sub.Name); - Write_Type_Id (Sub.Basetype, Ctxt); - Write_Range - (Sub.Basetype, - To_Ghdl_Range_Ptr (Loc_To_Addr (Rti.Depth, - Sub.Range_Loc, - Ctxt))); - end; - when Ghdl_Rtik_Type_I32 - | Ghdl_Rtik_Type_I64 - | Ghdl_Rtik_Type_F64 => - declare - Base : Ghdl_Rtin_Type_Scalar_Acc; - begin - Base := To_Ghdl_Rtin_Type_Scalar_Acc (Rti); - Write_String_Id (Base.Name); - end; - when Ghdl_Rtik_Type_P32 - | Ghdl_Rtik_Type_P64 => - declare - Base : Ghdl_Rtin_Type_Physical_Acc; - Unit : Ghdl_Rti_Access; - begin - Base := To_Ghdl_Rtin_Type_Physical_Acc (Rti); - Write_String_Id (Base.Name); - Wave_Put_ULEB128 (Ghdl_U32 (Base.Nbr)); - for I in 1 .. Base.Nbr loop - Unit := Base.Units (I - 1); - Write_String_Id - (Rtis_Utils.Get_Physical_Unit_Name (Unit)); - case Unit.Kind is - when Ghdl_Rtik_Unit64 => - Wave_Put_LSLEB128 - (To_Ghdl_Rtin_Unit64_Acc (Unit).Value); - when Ghdl_Rtik_Unitptr => - case Rti.Kind is - when Ghdl_Rtik_Type_P64 => - Wave_Put_LSLEB128 - (To_Ghdl_Rtin_Unitptr_Acc (Unit). - Addr.I64); - when Ghdl_Rtik_Type_P32 => - Wave_Put_SLEB128 - (To_Ghdl_Rtin_Unitptr_Acc (Unit). - Addr.I32); - when others => - Internal_Error - ("wave.write_types(P32/P64-1)"); - end case; - when others => - Internal_Error - ("wave.write_types(P32/P64-2)"); - end case; - end loop; - end; - when others => - Internal_Error ("wave.write_types"); - -- Internal_Error ("wave.write_types: does not handle " & - -- Ghdl_Rtik'Image (Rti.Kind)); - end case; - end if; - end loop; - Wave_Put_Byte (0); - end Write_Types; - - procedure Write_Known_Types - is - use Grt.Rtis_Types; - - Boolean_Type_Id : AVL_Nid; - Bit_Type_Id : AVL_Nid; - Std_Ulogic_Type_Id : AVL_Nid; - - function Search_Type_Id (Rti : Ghdl_Rti_Access) return AVL_Nid - is - Ctxt : Rti_Context; - Tid : AVL_Nid; - begin - Find_Type (Rti, Null_Context, Ctxt, Tid); - return Tid; - end Search_Type_Id; - begin - Search_Types_RTI; - - Boolean_Type_Id := Search_Type_Id (Std_Standard_Boolean_RTI_Ptr); - - Bit_Type_Id := Search_Type_Id (Std_Standard_Bit_RTI_Ptr); - - if Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr /= null then - Std_Ulogic_Type_Id := Search_Type_Id - (Ieee_Std_Logic_1164_Std_Ulogic_RTI_Ptr); - else - Std_Ulogic_Type_Id := AVL_Nil; - end if; - - Wave_Section ("WKT" & NUL); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - - if Boolean_Type_Id /= AVL_Nil then - Wave_Put_Byte (1); - Write_Type_Id (Boolean_Type_Id); - end if; - - if Bit_Type_Id /= AVL_Nil then - Wave_Put_Byte (2); - Write_Type_Id (Bit_Type_Id); - end if; - - if Std_Ulogic_Type_Id /= AVL_Nil then - Wave_Put_Byte (3); - Write_Type_Id (Std_Ulogic_Type_Id); - end if; - - Wave_Put_Byte (0); - end Write_Known_Types; - - -- Table of signals to be dumped. - package Dump_Table is new Grt.Table - (Table_Component_Type => Ghdl_Signal_Ptr, - Table_Index_Type => Natural, - Table_Low_Bound => 1, - Table_Initial => 32); - - function Get_Dump_Entry (N : Natural) return Ghdl_Signal_Ptr is - begin - return Dump_Table.Table (N); - end Get_Dump_Entry; - - pragma Unreferenced (Get_Dump_Entry); - - procedure Write_Hierarchy (Root : VhpiHandleT) - is - N : Natural; - begin - -- Check Alink is 0. - for I in Sig_Table.First .. Sig_Table.Last loop - if Sig_Table.Table (I).Alink /= null then - Internal_Error ("wave.write_hierarchy"); - end if; - end loop; - - Wave_Section ("HIE" & NUL); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_I32 (Ghdl_I32 (Nbr_Scopes)); - Wave_Put_I32 (Ghdl_I32 (Nbr_Scope_Signals)); - Wave_Put_I32 (Ghdl_I32 (Sig_Table.Last - Sig_Table.First + 1)); - Wave_Put_Hierarchy (Root, Step_Hierarchy); - Wave_Put_Byte (0); - - Dump_Table.Set_Last (Nbr_Dumped_Signals); - for I in Dump_Table.First .. Dump_Table.Last loop - Dump_Table.Table (I) := null; - end loop; - - -- Save and clear. - for I in Sig_Table.First .. Sig_Table.Last loop - N := Get_Signal_Number (Sig_Table.Table (I)); - if N /= 0 then - if Dump_Table.Table (N) /= null then - Internal_Error ("wave.write_hierarchy(2)"); - end if; - Dump_Table.Table (N) := Sig_Table.Table (I); - Sig_Table.Table (I).Alink := null; - end if; - end loop; - end Write_Hierarchy; - - procedure Write_Signal_Value (Sig : Ghdl_Signal_Ptr) is - begin - -- FIXME: for some signals, the significant value is the driving value! - Write_Value (Sig.Value, Sig.Mode); - end Write_Signal_Value; - - procedure Write_Snapshot is - begin - Wave_Section ("SNP" & NUL); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_Byte (0); - Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); - - for I in Dump_Table.First .. Dump_Table.Last loop - Write_Signal_Value (Dump_Table.Table (I)); - end loop; - Wave_Put ("ESN" & NUL); - end Write_Snapshot; - - procedure Wave_Cycle; - - -- Called after elaboration. - procedure Wave_Start - is - Root : VhpiHandleT; - begin - -- Do nothing if there is no VCD file to generate. - if Wave_Stream = NULL_Stream then - return; - end if; - - Write_File_Header; - - -- FIXME: write infos - -- * date - -- * timescale - -- * design name ? - -- ... - - -- Put hierarchy. - Get_Root_Inst (Root); - -- Vcd_Search_Packages; - Wave_Put_Hierarchy (Root, Step_Name); - - Freeze_Strings; - - -- Register_Cycle_Hook (Vcd_Cycle'Access); - Write_Strings_Compress; - Write_Types; - Write_Known_Types; - Write_Hierarchy (Root); - - -- End of header mark. - Wave_Section ("EOH" & NUL); - - Write_Snapshot; - - Register_Cycle_Hook (Wave_Cycle'Access); - - fflush (Wave_Stream); - end Wave_Start; - - Wave_Time : Std_Time := 0; - In_Cyc : Boolean := False; - - procedure Wave_Close_Cyc - is - begin - Wave_Put_LSLEB128 (-1); - Wave_Put ("ECY" & NUL); - In_Cyc := False; - end Wave_Close_Cyc; - - procedure Wave_Cycle - is - Diff : Std_Time; - Sig : Ghdl_Signal_Ptr; - Last : Natural; - begin - if not In_Cyc then - Wave_Section ("CYC" & NUL); - Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); - In_Cyc := True; - else - Diff := Cycle_Time - Wave_Time; - Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); - end if; - Wave_Time := Cycle_Time; - - -- Dump signals. - Last := 0; - for I in Dump_Table.First .. Dump_Table.Last loop - Sig := Dump_Table.Table (I); - if Sig.Flags.Cyc_Event then - Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); - Last := I; - Write_Signal_Value (Sig); - Sig.Flags.Cyc_Event := False; - end if; - end loop; - Wave_Put_Byte (0); - end Wave_Cycle; - - -- Called at the end of the simulation. - procedure Wave_End is - begin - if Wave_Stream = NULL_Stream then - return; - end if; - if In_Cyc then - Wave_Close_Cyc; - end if; - Wave_Write_Directory; - fflush (Wave_Stream); - end Wave_End; - - Wave_Hooks : aliased constant Hooks_Type := - (Option => Wave_Option'Access, - Help => Wave_Help'Access, - Init => Wave_Init'Access, - Start => Wave_Start'Access, - Finish => Wave_End'Access); - - procedure Register is - begin - Register_Hooks (Wave_Hooks'Access); - end Register; -end Grt.Waves; |