diff options
Diffstat (limited to 'src/translate/grt/grt-disp_signals.adb')
| -rw-r--r-- | src/translate/grt/grt-disp_signals.adb | 524 |
1 files changed, 524 insertions, 0 deletions
diff --git a/src/translate/grt/grt-disp_signals.adb b/src/translate/grt/grt-disp_signals.adb new file mode 100644 index 000000000..424d20dcf --- /dev/null +++ b/src/translate/grt/grt-disp_signals.adb @@ -0,0 +1,524 @@ +-- 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; |