grt-waves.adb

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

   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;
         --  Kind.
         Wave_Put_Byte (Ghdl_Rtik'Pos (Rti.Kind));
         case Rti.Kind is
            when Ghdl_Rtik_Type_B2
              | 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
              | Ghdl_Rtik_Subtype_Array_Ptr =>
               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_Rtin_Unit_Acc;
               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 := To_Ghdl_Rtin_Unit_Acc (Base.Units (I - 1));
                     Write_String_Id (Unit.Name);
                     case Base.Common.Mode is
                        when 0 =>
                           --  Value is locally static.
                           case Base.Common.Kind is
                              when Ghdl_Rtik_Type_P32 =>
                                 Wave_Put_SLEB128 (Unit.Value.Unit_32);
                              when Ghdl_Rtik_Type_P64 =>
                                 Wave_Put_LSLEB128 (Unit.Value.Unit_64);
                              when others =>
                                 Internal_Error
                                   ("wave.write_types(P32/P64-0)");
                           end case;
                        when 1 =>
                           case Rti.Kind is
                              when Ghdl_Rtik_Type_P32 =>
                                 Wave_Put_SLEB128 (Unit.Value.Unit_Addr.I32);
                              when Ghdl_Rtik_Type_P64 =>
                                 Wave_Put_LSLEB128 (Unit.Value.Unit_Addr.I64);
                              when others =>
                                 Internal_Error
                                   ("wave.write_types(P32/P64-1)");
                           end case;
                        when others =>
                           Internal_Error ("wave.write_types(P32/P64)");
                     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 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 GNAT.Table
     (Table_Component_Type => Ghdl_Signal_Ptr,
      Table_Index_Type => Natural,
      Table_Low_Bound => 1,
      Table_Initial => 32,
      Table_Increment => 100);

   procedure Write_Hierarchy (Root : VhpiHandleT)
   is
      function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
        (Source => Integer_Address, Target => Ghdl_Signal_Ptr);
      N : Natural;
   begin
      --  Number signals.
      for I in Sig_Table.First .. Sig_Table.Last loop
         if Sig_Table.Table (I).Flink /= null then
            Internal_Error ("wave.write_hierarchy");
         end if;
         Sig_Table.Table (I).Flink :=
           To_Ghdl_Signal_Ptr (Integer_Address (I - Sig_Table.First + 1));
      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);

      --  Save and clear.
      N := 0;
      for I in Sig_Table.First .. Sig_Table.Last loop
         if Sig_Table.Table (I).Flags.Is_Dumped then
            N := N + 1;
            Dump_Table.Table (N) := Sig_Table.Table (I);
         end if;
         Sig_Table.Table (I).Flink := null;
      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;