grt-waves.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  GHDL Run Time (GRT) - wave dumper (GHW) module.
--  Copyright (C) 2002, 2003, 2004, 2005 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.
with Ada.Unchecked_Conversion;
with Ada.Unchecked_Deallocation;
with Interfaces; use Interfaces;
with System.Storage_Elements; --  Work around GNAT bug.
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.Types; use Grt.Types;
with Grt.Astdio; use Grt.Astdio;
with Grt.Hooks; use Grt.Hooks;
with Grt.Avhpi; use Grt.Avhpi;
with GNAT.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);

package body Grt.Waves is
   --  Waves filename.
   Wave_Filename : String_Access := null;
   --  Stream corresponding to the VCD 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_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

   --  Return TRUE if OPT is an option for VCD.
   function Wave_Option (Opt : String) return Boolean
   is
      F : 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;
   begin
      R := fwrite (Str'Address, Str'Length, 1, Wave_Stream);
   end Wave_Put;

   procedure Wave_Putc (C : Character)
   is
      R : int;
   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;
   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;
   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;
   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;
   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_B2 =>
            Wave_Put_Byte (Ghdl_B2'Pos (Value.B2));
         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 GNAT.Table
     (Table_Component_Type => Header_Type,
      Table_Index_Type => Natural,
      Table_Low_Bound => 1,
      Table_Initial => 16,
      Table_Increment => 100);

   --  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.
      if Integer'Size = 32 then
         Wave_Put_Byte (4);
      elsif Integer'Size = 64 then
         Wave_Put_Byte (8);
      else
         Wave_Put_Byte (0);
      end if;
      --  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 := "wt" & 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 ("Wave.Avhpi_Error!");
      null;
   end Avhpi_Error;

   package Str_Table is new GNAT.Table
     (Table_Component_Type => Ghdl_C_String,
      Table_Index_Type => AVL_Value,
      Table_Low_Bound => 1,
      Table_Initial => 16,
      Table_Increment => 100);

   package Str_AVL is new GNAT.Table
     (Table_Component_Type => AVL_Node,
      Table_Index_Type => AVL_Nid,
      Table_Low_Bound => AVL_Root,
      Table_Initial => 16,
      Table_Increment => 100);

   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;