grt-waves.adb

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

      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_B2 =>
            Mode := Mode_B2;
         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;

   procedure Write_Signal_Number (Val_Addr : Address;
                                  Val_Name : Vstring;
                                  Val_Type : Ghdl_Rti_Access)
   is
      pragma Unreferenced (Val_Name);
      pragma Unreferenced (Val_Type);

      function To_Integer_Address is new Ada.Unchecked_Conversion
        (Ghdl_Signal_Ptr, Integer_Address);
      Sig : Ghdl_Signal_Ptr;
   begin
      Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
      if not Sig.Flags.Is_Dumped then
         Sig.Flags.Is_Dumped := True;
         Nbr_Dumped_Signals := Nbr_Dumped_Signals + 1;
      end if;
      Wave_Put_ULEB128 (Ghdl_E32 (To_Integer_Address (Sig.Flink)));
   end Write_Signal_Number;

   procedure Foreach_Scalar_Signal_Number is new
     Grt.Rtis_Utils.Foreach_Scalar (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);
   end Write_Signal_Numbers;

   procedure Write_Hierarchy_El (Decl : VhpiHandleT)
   is
      Mode2hie : constant array (VhpiModeP) 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 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;

   procedure Wave_Put_Hierarchy (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;

      --  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 =>
               case Step is
                  when Step_Name =>
                     Create_String_Id (Avhpi_Get_Base_Name (Decl));
                     if Vhpi_Get_Kind (Decl) = VhpiForGenerateK then
                        Create_Generate_Type (Decl);
                     end if;
                  when Step_Hierarchy =>
                     Write_Hierarchy_El (Decl);
               end case;
               Wave_Put_Hierarchy (Decl, Step);
               if Step = Step_Hierarchy then
                  Wave_Put_Byte (Ghw_Hie_Eos);
               end if;
            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");
--                 Wave_Put ("unknown ");
--                 Wave_Put (VhpiClassKindT'Image (Vhpi_Get_Kind (Decl)));
--                 Wave_Newline;
         end case;
      end loop;
   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;

   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_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;