diff options
Diffstat (limited to 'translate/grt/grt-disp_rti.adb')
| -rw-r--r-- | translate/grt/grt-disp_rti.adb | 390 |
1 files changed, 28 insertions, 362 deletions
diff --git a/translate/grt/grt-disp_rti.adb b/translate/grt/grt-disp_rti.adb index 28ad75d..e9ac3e6 100644 --- a/translate/grt/grt-disp_rti.adb +++ b/translate/grt/grt-disp_rti.adb @@ -15,14 +15,10 @@ -- 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 System; use System; -with Grt.Rtis; use Grt.Rtis; -with Grt.Stdio; use Grt.Stdio; with Grt.Astdio; use Grt.Astdio; -with Grt.Types; use Grt.Types; with Grt.Errors; use Grt.Errors; with Grt.Rtis_Addr; use Grt.Rtis_Addr; -with Grt.Options; use Grt.Options; +with Grt.Hooks; use Grt.Hooks; package body Grt.Disp_Rti is procedure Disp_Kind (Kind : Ghdl_Rtik); @@ -119,12 +115,6 @@ package body Grt.Disp_Rti is -- end case; -- end Get_Scalar_Type_Kind; - procedure Disp_Value (Stream : FILEs; - Rti : Ghdl_Rti_Access; - Ctxt : Rti_Context; - Obj : in out Address; - Is_Sig : Boolean); - procedure Disp_Array_Value_1 (Stream : FILEs; El_Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; @@ -989,10 +979,16 @@ package body Grt.Disp_Rti is end case; end Disp_Rti; + Disp_Rti_Flag : Boolean := False; + procedure Disp_All is Ctxt : Rti_Context; begin + if not Disp_Rti_Flag then + return; + end if; + Put ("DISP_RTI.Disp_All: "); Disp_Kind (Ghdl_Rti_Top_Ptr.Common.Kind); New_Line; @@ -1006,364 +1002,34 @@ package body Grt.Disp_Rti is --Disp_Hierarchy; end Disp_All; - -- Get next interesting child. - procedure Get_Tree_Child (Parent : Ghdl_Rtin_Block_Acc; - Index : in out Ghdl_Index_Type; - Child : out Ghdl_Rti_Access) - is - begin - -- Exit if no more children. - while Index < Parent.Nbr_Child loop - Child := Parent.Children (Index); - Index := Index + 1; - case Child.Kind is - when Ghdl_Rtik_Package - | Ghdl_Rtik_Entity - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Block - | Ghdl_Rtik_For_Generate - | Ghdl_Rtik_If_Generate - | Ghdl_Rtik_Instance => - return; - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard => - if Disp_Tree >= Disp_Tree_Port then - return; - end if; - when Ghdl_Rtik_Process => - if Disp_Tree >= Disp_Tree_Proc then - return; - end if; - when others => - null; - end case; - end loop; - Child := null; - end Get_Tree_Child; - - procedure Disp_Tree_Child (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context) + function Disp_Rti_Option (Opt : String) return Boolean is begin - case Rti.Kind is - when Ghdl_Rtik_Entity - | Ghdl_Rtik_Process - | Ghdl_Rtik_Architecture - | Ghdl_Rtik_Block - | Ghdl_Rtik_If_Generate => - declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); - begin - Disp_Name (Blk.Name); - end; - when Ghdl_Rtik_Package_Body - | Ghdl_Rtik_Package => - declare - Blk : Ghdl_Rtin_Block_Acc; - Lib : Ghdl_Rtin_Type_Scalar_Acc; - begin - Blk := To_Ghdl_Rtin_Block_Acc (Rti); - if Rti.Kind = Ghdl_Rtik_Package_Body then - Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); - end if; - Lib := To_Ghdl_Rtin_Type_Scalar_Acc (Blk.Parent); - Disp_Name (Lib.Name); - Put ('.'); - Disp_Name (Blk.Name); - end; - when Ghdl_Rtik_For_Generate => - declare - Blk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Rti); - Iter : Ghdl_Rtin_Object_Acc; - Addr : Address; - begin - Disp_Name (Blk.Name); - Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); - Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); - Put ('('); - Disp_Value (stdout, Iter.Obj_Type, Ctxt, Addr, False); - Put (')'); - end; - when Ghdl_Rtik_Signal - | Ghdl_Rtik_Port - | Ghdl_Rtik_Guard - | Ghdl_Rtik_Iterator => - Disp_Name (To_Ghdl_Rtin_Object_Acc (Rti).Name); - when Ghdl_Rtik_Instance => - Disp_Name (To_Ghdl_Rtin_Instance_Acc (Rti).Name); - when others => - null; - end case; - - case Rti.Kind is - when Ghdl_Rtik_Package - | Ghdl_Rtik_Package_Body => - Put (" [package]"); - when Ghdl_Rtik_Entity => - Put (" [entity]"); - when Ghdl_Rtik_Architecture => - Put (" [arch]"); - when Ghdl_Rtik_Process => - Put (" [process]"); - when Ghdl_Rtik_Block => - Put (" [block]"); - when Ghdl_Rtik_For_Generate => - Put (" [for-generate]"); - when Ghdl_Rtik_If_Generate => - Put (" [if-generate "); - if Ctxt.Base = Null_Address then - Put ("false]"); - else - Put ("true]"); - end if; - when Ghdl_Rtik_Signal => - Put (" [signal]"); - when Ghdl_Rtik_Port => - Put (" [port "); - case Rti.Mode and Ghdl_Rti_Signal_Mode_Mask is - when Ghdl_Rti_Signal_Mode_In => - Put ("in"); - when Ghdl_Rti_Signal_Mode_Out => - Put ("out"); - when Ghdl_Rti_Signal_Mode_Inout => - Put ("inout"); - when Ghdl_Rti_Signal_Mode_Buffer => - Put ("buffer"); - when Ghdl_Rti_Signal_Mode_Linkage => - Put ("linkage"); - when others => - Put ("?"); - end case; - Put ("]"); - when Ghdl_Rtik_Guard => - Put (" [guard]"); - when Ghdl_Rtik_Iterator => - Put (" [iterator]"); - when Ghdl_Rtik_Instance => - Put (" [instance]"); - when others => - null; - end case; - end Disp_Tree_Child; - - procedure Disp_Tree_Block - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String); + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; - procedure Disp_Tree_Block1 - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) + procedure Disp_Rti_Help is - Child : Ghdl_Rti_Access; - Child2 : Ghdl_Rti_Access; - Index : Ghdl_Index_Type; - - procedure Disp_Header (Nctxt : Rti_Context; - Force_Cont : Boolean := False) - is - begin - Put (Pfx); - - if Blk.Common.Kind /= Ghdl_Rtik_Entity - and Child2 = null - and Force_Cont = False - then - Put ("`-"); - else - Put ("+-"); - end if; - - Disp_Tree_Child (Child, Nctxt); - New_Line; - end Disp_Header; - - procedure Disp_Sub_Block - (Sub_Blk : Ghdl_Rtin_Block_Acc; Nctxt : Rti_Context) - is - Npfx : String (1 .. Pfx'Length + 2); - begin - Npfx (1 .. Pfx'Length) := Pfx; - Npfx (Pfx'Length + 2) := ' '; - if Child2 = null then - Npfx (Pfx'Length + 1) := ' '; - else - Npfx (Pfx'Length + 1) := '|'; - end if; - Disp_Tree_Block (Sub_Blk, Nctxt, Npfx); - end Disp_Sub_Block; - + procedure P (Str : String) renames Put_Line; begin - Index := 0; - Get_Tree_Child (Blk, Index, Child); - while Child /= null loop - Get_Tree_Child (Blk, Index, Child2); + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; - case Child.Kind is - when Ghdl_Rtik_Process - | Ghdl_Rtik_Block => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => Ctxt.Base + Nblk.Loc.Off, - Block => Child); - Disp_Header (Nctxt, False); - Disp_Sub_Block (Nblk, Nctxt); - end; - when Ghdl_Rtik_For_Generate => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - Length : Ghdl_Index_Type; - Old_Child2 : Ghdl_Rti_Access; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, - Block => Child); - Length := Get_For_Generate_Length (Nblk, Ctxt); - Disp_Header (Nctxt, Length > 1); - Old_Child2 := Child2; - if Length > 1 then - Child2 := Child; - end if; - for I in 1 .. Length loop - Disp_Sub_Block (Nblk, Nctxt); - if I /= Length then - Nctxt.Base := Nctxt.Base + Nblk.Size; - if I = Length - 1 then - Child2 := Old_Child2; - end if; - Disp_Header (Nctxt); - end if; - end loop; - Child2 := Old_Child2; - end; - when Ghdl_Rtik_If_Generate => - declare - Nblk : Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Child); - Nctxt : Rti_Context; - begin - Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc.Off).all, - Block => Child); - Disp_Header (Nctxt); - if Nctxt.Base /= Null_Address then - Disp_Sub_Block (Nblk, Nctxt); - end if; - end; - when Ghdl_Rtik_Instance => - declare - Inst : Ghdl_Rtin_Instance_Acc; - Sub_Ctxt : Rti_Context; - Sub_Blk : Ghdl_Rtin_Block_Acc; - Npfx : String (1 .. Pfx'Length + 4); - Comp : Ghdl_Rtin_Component_Acc; - Ch : Ghdl_Rti_Access; - begin - Disp_Header (Ctxt); - Inst := To_Ghdl_Rtin_Instance_Acc (Child); - Get_Instance_Context (Inst, Ctxt, Sub_Ctxt); - Sub_Blk := To_Ghdl_Rtin_Block_Acc (Sub_Ctxt.Block); - if Inst.Instance.Kind = Ghdl_Rtik_Component - and then Disp_Tree >= Disp_Tree_Port - then - -- Disp generics and ports of the component. - Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); - for I in 1 .. Comp.Nbr_Child loop - Ch := Comp.Children (I - 1); - if Ch.Kind = Ghdl_Rtik_Port then - -- Disp only port (and not generics). - Put (Pfx); - if Child2 = null then - Put (" "); - else - Put ("| "); - end if; - if I = Comp.Nbr_Child and then Sub_Blk = null then - Put ("`-"); - else - Put ("+-"); - end if; - Disp_Tree_Child (Ch, Sub_Ctxt); - New_Line; - end if; - end loop; - end if; - if Sub_Blk /= null then - Npfx (1 .. Pfx'Length) := Pfx; - if Child2 = null then - Npfx (Pfx'Length + 1) := ' '; - else - Npfx (Pfx'Length + 1) := '|'; - end if; - Npfx (Pfx'Length + 2) := ' '; - Npfx (Pfx'Length + 3) := '`'; - Npfx (Pfx'Length + 4) := '-'; - Put (Npfx); - Disp_Tree_Child (Sub_Blk.Parent, Sub_Ctxt); - New_Line; - Npfx (Pfx'Length + 3) := ' '; - Npfx (Pfx'Length + 4) := ' '; - Disp_Tree_Block (Sub_Blk, Sub_Ctxt, Npfx); - end if; - end; - when others => - Disp_Header (Ctxt); - end case; - - Child := Child2; - end loop; - end Disp_Tree_Block1; + Disp_Rti_Hooks : aliased constant Hooks_Type := + (Option => Disp_Rti_Option'Access, + Help => Disp_Rti_Help'Access, + Init => null, + Start => Disp_All'Access, + Finish => null); - procedure Disp_Tree_Block - (Blk : Ghdl_Rtin_Block_Acc; Ctxt : Rti_Context; Pfx : String) - is + procedure Register is begin - case Blk.Common.Kind is - when Ghdl_Rtik_Architecture => - declare - Npfx : String (1 .. Pfx'Length + 2); - Nctxt : Rti_Context; - begin - -- The entity. - Nctxt := (Base => Ctxt.Base, - Block => Blk.Parent); - Disp_Tree_Block1 - (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Nctxt, Pfx); - -- Then the architecture. - Put (Pfx); - Put ("`-"); - Disp_Tree_Child (To_Ghdl_Rti_Access (Blk), Ctxt); - New_Line; - Npfx (1 .. Pfx'Length) := Pfx; - Npfx (Pfx'Length + 1) := ' '; - Npfx (Pfx'Length + 2) := ' '; - Disp_Tree_Block1 (Blk, Ctxt, Npfx); - end; - when Ghdl_Rtik_Package_Body => - Disp_Tree_Block1 - (To_Ghdl_Rtin_Block_Acc (Blk.Parent), Ctxt, Pfx); - when others => - Disp_Tree_Block1 (Blk, Ctxt, Pfx); - end case; - end Disp_Tree_Block; - - procedure Disp_Hierarchy - is - Ctxt : Rti_Context; - Parent : Ghdl_Rtin_Block_Acc; - Child : Ghdl_Rti_Access; - begin - Ctxt := Get_Top_Context; - Parent := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); - - Disp_Tree_Child (Parent.Parent, Ctxt); - New_Line; - Disp_Tree_Block (Parent, Ctxt, ""); + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; - for I in 1 .. Ghdl_Rti_Top_Ptr.Nbr_Child loop - Child := Ghdl_Rti_Top_Ptr.Children (I - 1); - Ctxt := (Base => Null_Address, - Block => Child); - Disp_Tree_Child (Child, Ctxt); - New_Line; - Disp_Tree_Block (To_Ghdl_Rtin_Block_Acc (Child), Ctxt, ""); - end loop; - end Disp_Hierarchy; end Grt.Disp_Rti; |