diff options
Diffstat (limited to 'src/grt/grt-waves.adb')
| -rw-r--r-- | src/grt/grt-waves.adb | 1632 |
1 files changed, 1632 insertions, 0 deletions
diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb new file mode 100644 index 0000000..63bdb9a --- /dev/null +++ b/src/grt/grt-waves.adb @@ -0,0 +1,1632 @@ +-- 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; |