path: root/src/grt/grt-disp_signals.adb

--  GHDL Run Time (GRT) - Display subprograms for signals.
--  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 System; use System;
with System.Storage_Elements; --  Work around GNAT bug.
pragma Unreferenced (System.Storage_Elements);
with Ada.Unchecked_Conversion;
with Grt.Rtis; use Grt.Rtis;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Rtis_Utils; use Grt.Rtis_Utils;
with Grt.Astdio; use Grt.Astdio;
with Grt.Errors; use Grt.Errors;
pragma Elaborate_All (Grt.Rtis_Utils);
with Grt.Vstrings; use Grt.Vstrings;
with Grt.Options;
with Grt.Processes;
with Grt.Disp; use Grt.Disp;

package body Grt.Disp_Signals is
   procedure Foreach_Scalar_Signal
     (Process : access procedure (Val_Addr : Address;
                                  Val_Name : Vstring;
                                  Val_Type : Ghdl_Rti_Access;
                                  Param : Rti_Object))
   is
      procedure Call_Process (Val_Addr : Address;
                              Val_Name : Vstring;
                              Val_Type : Ghdl_Rti_Access;
                              Param : Rti_Object) is
      begin
         Process.all (Val_Addr, Val_Name, Val_Type, Param);
      end Call_Process;

      pragma Inline (Call_Process);

      procedure Foreach_Scalar_Signal_Signal is new
        Foreach_Scalar (Param_Type => Rti_Object,
                        Process => Call_Process);

      function Foreach_Scalar_Signal_Object
        (Ctxt : Rti_Context; Obj : Ghdl_Rti_Access)
        return Traverse_Result
      is
         Sig : Ghdl_Rtin_Object_Acc;
      begin
         case Obj.Kind is
            when Ghdl_Rtik_Signal
              | Ghdl_Rtik_Port
              | Ghdl_Rtik_Guard
              | Ghdl_Rtik_Attribute_Quiet
              | Ghdl_Rtik_Attribute_Stable
              | Ghdl_Rtik_Attribute_Transaction =>
               Sig := To_Ghdl_Rtin_Object_Acc (Obj);
               Foreach_Scalar_Signal_Signal
                 (Ctxt, Sig.Obj_Type,
                  Loc_To_Addr (Sig.Common.Depth, Sig.Loc, Ctxt), True,
                  Rti_Object'(Obj, Ctxt));
            when others =>
               null;
         end case;
         return Traverse_Ok;
      end Foreach_Scalar_Signal_Object;

      function Foreach_Scalar_Signal_Traverse is
         new Traverse_Blocks (Process => Foreach_Scalar_Signal_Object);

      Res : Traverse_Result;
      pragma Unreferenced (Res);
   begin
      Res := Foreach_Scalar_Signal_Traverse (Get_Top_Context);
   end Foreach_Scalar_Signal;

   procedure Disp_Context (Ctxt : Rti_Context)
   is
      Blk : Ghdl_Rtin_Block_Acc;
      Nctxt : Rti_Context;
   begin
      Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
      case Blk.Common.Kind is
         when Ghdl_Rtik_Block
           | Ghdl_Rtik_Process =>
            Nctxt := Get_Parent_Context (Ctxt);
            Disp_Context (Nctxt);
            Put ('.');
            Put (Blk.Name);
         when Ghdl_Rtik_Entity =>
            Put (Blk.Name);
         when Ghdl_Rtik_Architecture =>
            Nctxt := Get_Parent_Context (Ctxt);
            Disp_Context (Nctxt);
            Put ('(');
            Put (Blk.Name);
            Put (')');
         when others =>
            Internal_Error ("disp_context");
      end case;
   end Disp_Context;

   --  This is a debugging procedure.
   pragma Unreferenced (Disp_Context);

   --  Option --trace-signals.

   --  Disp transaction TRANS from signal SIG.
   procedure Disp_Transaction (Trans : Transaction_Acc;
                               Sig_Type : Ghdl_Rti_Access;
                               Mode : Mode_Type)
   is
      T : Transaction_Acc;
   begin
      T := Trans;
      loop
         case T.Kind is
            when Trans_Value =>
               if Sig_Type /= null then
                  Disp_Value (stdout, T.Val, Sig_Type);
               else
                  Disp_Value (T.Val, Mode);
               end if;
            when Trans_Direct =>
               if Sig_Type /= null then
                  Disp_Value (stdout, T.Val_Ptr.all, Sig_Type);
               else
                  Disp_Value (T.Val_Ptr.all, Mode);
               end if;
            when Trans_Null =>
               Put ("NULL");
            when Trans_Error =>
               Put ("ERROR");
         end case;
         if T.Kind = Trans_Direct then
            --  The Time field is not updated for direct transaction.
            Put ("[DIRECT]");
         else
            Put ("@");
            Put_Time (stdout, T.Time);
         end if;
         T := T.Next;
         exit when T = null;
         Put (", ");
      end loop;
   end Disp_Transaction;

   procedure Disp_Simple_Signal
     (Sig : Ghdl_Signal_Ptr; Sig_Type : Ghdl_Rti_Access; Sources : Boolean)
   is
      function To_Address is new Ada.Unchecked_Conversion
        (Source => Resolved_Signal_Acc, Target => Address);
   begin
      Put (' ');
      Put (stdout, Sig.all'Address);
      Put (' ');
      Disp_Mode (Sig.Mode);
      Put (' ');
      if Sig.Active then
         Put ('A');
      else
         Put ('-');
      end if;
      if Sig.Event then
         Put ('E');
      else
         Put ('-');
      end if;
      if Sig.Has_Active then
         Put ('a');
      else
         Put ('-');
      end if;
      if Sig.S.Effective /= null then
         Put ('e');
      else
         Put ('-');
      end if;
      if Boolean'(True) then
         Put (" last_event=");
         Put_Time (stdout, Sig.Last_Event);
         Put (" last_active=");
         Put_Time (stdout, Sig.Last_Active);
      end if;
      Put (" val=");
      if Sig_Type /= null then
         Disp_Value (stdout, Sig.Value, Sig_Type);
      else
         Disp_Value (Sig.Value, Sig.Mode);
      end if;
      Put ("; drv=");
      if Sig_Type /= null then
         Disp_Value (stdout, Sig.Driving_Value, Sig_Type);
      else
         Disp_Value (Sig.Driving_Value, Sig.Mode);
      end if;
      if Sources then
         if Sig.Nbr_Ports > 0 then
            Put (';');
            Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
            Put (" ports");
         end if;
         if Sig.S.Mode_Sig in Mode_Signal_User then
            if Sig.S.Resolv /= null then
               Put (stdout, " res func ");
               Put (stdout, To_Address(Sig.S.Resolv));
            end if;
            if Sig.S.Nbr_Drivers = 0 then
               Put ("; no driver");
            elsif Sig.S.Nbr_Drivers = 1 then
               Put ("; trans=");
               Disp_Transaction
                 (Sig.S.Drivers (0).First_Trans, Sig_Type, Sig.Mode);
            else
               for I in 0 .. Sig.S.Nbr_Drivers - 1 loop
                  New_Line;
                  Put ("   ");
                  Disp_Transaction
                    (Sig.S.Drivers (I).First_Trans, Sig_Type, Sig.Mode);
               end loop;
            end if;
         end if;
      end if;
      New_Line;
   end Disp_Simple_Signal;

   procedure Disp_Signal_Name (Stream : FILEs;
                               Ctxt : Rti_Context;
                               Sig : Ghdl_Rtin_Object_Acc) is
   begin
      case Sig.Common.Kind is
         when Ghdl_Rtik_Signal
           | Ghdl_Rtik_Port
           | Ghdl_Rtik_Guard =>
            Put (stdout, Ctxt);
            Put (".");
            Put (Stream, Sig.Name);
         when Ghdl_Rtik_Attribute_Quiet =>
            Put (stdout, Ctxt);
            Put (".");
            Put (Stream, " 'quiet");
         when Ghdl_Rtik_Attribute_Stable =>
            Put (stdout, Ctxt);
            Put (".");
            Put (Stream, " 'stable");
         when Ghdl_Rtik_Attribute_Transaction =>
            Put (stdout, Ctxt);
            Put (".");
            Put (Stream, " 'transaction");
         when others =>
            null;
      end case;
   end Disp_Signal_Name;

   procedure Disp_Scalar_Signal (Val_Addr : Address;
                                 Val_Name : Vstring;
                                 Val_Type : Ghdl_Rti_Access;
                                 Parent : Rti_Object)
   is
   begin
      Disp_Signal_Name (stdout, Parent.Ctxt,
                        To_Ghdl_Rtin_Object_Acc (Parent.Obj));
      Put (stdout, Val_Name);
      Disp_Simple_Signal (To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all),
                          Val_Type, Options.Disp_Sources);
   end Disp_Scalar_Signal;


   procedure Disp_All_Signals is
   begin
      Foreach_Scalar_Signal (Disp_Scalar_Signal'access);
   end Disp_All_Signals;

   --  Option disp-sensitivity

   procedure Disp_Scalar_Sensitivity (Val_Addr : Address;
                                      Val_Name : Vstring;
                                      Val_Type : Ghdl_Rti_Access;
                                      Parent : Rti_Object)
   is
      pragma Unreferenced (Val_Type);
      Sig : Ghdl_Signal_Ptr;

      Action : Action_List_Acc;
   begin
      Sig := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
      if Sig.Flags.Seen then
         return;
      else
         Sig.Flags.Seen := True;
      end if;
      Disp_Signal_Name (stdout, Parent.Ctxt,
                        To_Ghdl_Rtin_Object_Acc (Parent.Obj));
      Put (stdout, Val_Name);
      New_Line (stdout);

      Action := Sig.Event_List;
      while Action /= null loop
         Put (stdout, "  wakeup ");
         Grt.Processes.Disp_Process_Name (stdout, Action.Proc);
         New_Line (stdout);
         Action := Action.Next;
      end loop;

      if Sig.S.Mode_Sig in Mode_Signal_User then
         for I in 1 .. Sig.S.Nbr_Drivers loop
            Put (stdout, "  driven ");
            Grt.Processes.Disp_Process_Name
              (stdout, Sig.S.Drivers (I - 1).Proc);
            New_Line (stdout);
         end loop;
      end if;
   end Disp_Scalar_Sensitivity;

   procedure Disp_All_Sensitivity is
   begin
      Foreach_Scalar_Signal (Disp_Scalar_Sensitivity'access);
   end Disp_All_Sensitivity;


   --  Option disp-signals-map

   procedure Disp_Signals_Map_Scalar (Val_Addr : Address;
                                      Val_Name : Vstring;
                                      Val_Type : Ghdl_Rti_Access;
                                      Parent : Rti_Object)
   is
      pragma Unreferenced (Val_Type);

      function To_Ghdl_Signal_Ptr is new Ada.Unchecked_Conversion
        (Source => Address, Target => Ghdl_Signal_Ptr);

      S : Ghdl_Signal_Ptr;
   begin
      Disp_Signal_Name (stdout,
                        Parent.Ctxt, To_Ghdl_Rtin_Object_Acc (Parent.Obj));
      Put (stdout, Val_Name);
      Put (": ");
      S := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
      Put (stdout, S.all'Address);
      Put (" net: ");
      Put_I32 (stdout, Ghdl_I32 (S.Net));
      if S.Has_Active then
         Put (" +A");
      end if;
      New_Line;
   end Disp_Signals_Map_Scalar;

   procedure Disp_Signals_Map is
   begin
      Foreach_Scalar_Signal (Disp_Signals_Map_Scalar'access);
   end Disp_Signals_Map;

   --  Option --disp-signals-table
   procedure Disp_Mode_Signal (Mode : Mode_Signal_Type)
   is
   begin
      case Mode is
         when Mode_Signal =>
            Put ("signal");
         when Mode_Linkage =>
            Put ("linkage");
         when Mode_Buffer =>
            Put ("buffer");
         when Mode_Out =>
            Put ("out");
         when Mode_Inout =>
            Put ("inout");
         when Mode_In =>
            Put ("in");
         when Mode_Stable =>
            Put ("stable");
         when Mode_Quiet =>
            Put ("quiet");
         when Mode_Transaction =>
            Put ("transaction");
         when Mode_Delayed =>
            Put ("delayed");
         when Mode_Guard =>
            Put ("guard");
         when Mode_Conv_In =>
            Put ("conv_in");
         when Mode_Conv_Out =>
            Put ("conv_out");
         when Mode_End =>
            Put ("end");
      end case;
   end Disp_Mode_Signal;

   procedure Disp_Signals_Table
   is
      Sig : Ghdl_Signal_Ptr;
   begin
      for I in Sig_Table.First .. Sig_Table.Last loop
         Sig := Sig_Table.Table (I);
         Put_Sig_Index (I);
         Put (": ");
         Put (stdout, Sig.all'Address);
         if Sig.Has_Active then
            Put (" +A");
         end if;
         Put (" net: ");
         Put_I32 (stdout,  Ghdl_I32 (Sig.Net));
         Put (" smode: ");
         Disp_Mode_Signal (Sig.S.Mode_Sig);
         Put (" #prt: ");
         Put_I32 (stdout, Ghdl_I32 (Sig.Nbr_Ports));
         if Sig.S.Mode_Sig in Mode_Signal_User then
            Put (" #drv: ");
            Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers));
            if Sig.S.Effective /= null then
               Put (" eff: ");
               Put (stdout, Sig.S.Effective.all'Address);
            end if;
            if Sig.S.Resolv /= null then
               Put (" resolved");
            end if;
         end if;
         if Boolean'(False) then
            Put (" link: ");
            Put (stdout, Sig.Link.all'Address);
         end if;
         New_Line;
         if Sig.Nbr_Ports /= 0 then
            for J in 1 .. Sig.Nbr_Ports loop
               Put ("  ");
               Put (stdout, Sig.Ports (J - 1).all'Address);
            end loop;
            New_Line;
         end if;
      end loop;
      Grt.Stdio.fflush (stdout);
   end Disp_Signals_Table;

   procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr)
   is
   begin
      Disp_Simple_Signal (Sig, null, True);
   end Disp_A_Signal;

   procedure Put_Signal_Name (Stream : FILEs; Sig : Ghdl_Signal_Ptr)
   is
      Found : Boolean := False;
      Cur_Ctxt : Rti_Context;
      Cur_Sig : Ghdl_Rtin_Object_Acc;

      procedure Process_Scalar  (Val_Addr : Address;
                                 Val_Name : Vstring;
                                 Val_Type : Ghdl_Rti_Access;
                                 Param : Boolean)
      is
         pragma Unreferenced (Val_Type);
         pragma Unreferenced (Param);
         Sig1 : Ghdl_Signal_Ptr;
      begin
         --  Read the signal.
         Sig1 := To_Ghdl_Signal_Ptr (To_Addr_Acc (Val_Addr).all);
         if Sig1 = Sig and not Found then
            Disp_Signal_Name (Stream, Cur_Ctxt, Cur_Sig);
            Put (Stream, Val_Name);
            Found := True;
         end if;
      end Process_Scalar;

      procedure Foreach_Scalar is new Grt.Rtis_Utils.Foreach_Scalar
        (Param_Type => Boolean, Process => Process_Scalar);

      function Process_Block (Ctxt : Rti_Context;
                              Obj : Ghdl_Rti_Access)
                             return Traverse_Result
      is
      begin
         case Obj.Kind is
            when Ghdl_Rtik_Signal
              | Ghdl_Rtik_Port
              | Ghdl_Rtik_Guard
              | Ghdl_Rtik_Attribute_Stable
              | Ghdl_Rtik_Attribute_Quiet
              | Ghdl_Rtik_Attribute_Transaction =>
               Cur_Ctxt := Ctxt;
               Cur_Sig := To_Ghdl_Rtin_Object_Acc (Obj);
               Foreach_Scalar
                 (Ctxt, Cur_Sig.Obj_Type,
                  Loc_To_Addr (Cur_Sig.Common.Depth, Cur_Sig.Loc, Ctxt),
                  True, True);
               if Found then
                  return Traverse_Stop;
               end if;
            when others =>
               null;
         end case;
         return Traverse_Ok;
      end Process_Block;

      function Foreach_Block is new Grt.Rtis_Utils.Traverse_Blocks
        (Process_Block);

      Res_Status : Traverse_Result;
      pragma Unreferenced (Res_Status);
   begin
      Res_Status := Foreach_Block (Get_Top_Context);
      if not Found then
         Put (Stream, "(unknown signal)");
      end if;
   end Put_Signal_Name;

end Grt.Disp_Signals;