diff options
Diffstat (limited to 'src/grt/grt-disp_rti.adb')
| -rw-r--r-- | src/grt/grt-disp_rti.adb | 1080 |
1 files changed, 1080 insertions, 0 deletions
diff --git a/src/grt/grt-disp_rti.adb b/src/grt/grt-disp_rti.adb new file mode 100644 index 0000000..08d27da --- /dev/null +++ b/src/grt/grt-disp_rti.adb @@ -0,0 +1,1080 @@ +-- GHDL Run Time (GRT) - RTI dumper. +-- 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 Grt.Astdio; use Grt.Astdio; +with Grt.Errors; use Grt.Errors; +with Grt.Hooks; use Grt.Hooks; +with Grt.Rtis_Utils; use Grt.Rtis_Utils; + +package body Grt.Disp_Rti is + procedure Disp_Kind (Kind : Ghdl_Rtik); + + procedure Disp_Name (Name : Ghdl_C_String) is + begin + if Name = null then + Put (stdout, "<anonymous>"); + else + Put (stdout, Name); + end if; + end Disp_Name; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Disp_Enum_Value + (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) + is + Enum_Rti : Ghdl_Rtin_Type_Enum_Acc; + begin + Enum_Rti := To_Ghdl_Rtin_Type_Enum_Acc (Rti); + Put (Stream, Enum_Rti.Names (Val)); + end Disp_Enum_Value; + + procedure Disp_Scalar_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Addr : in out Address; + Is_Sig : Boolean) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + + Vptr : Ghdl_Value_Ptr; + begin + if Is_Sig then + Vptr := To_Ghdl_Value_Ptr (To_Addr_Acc (Addr).all); + Update (Address'Size); + else + Vptr := To_Ghdl_Value_Ptr (Addr); + end if; + + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Put_I32 (Stream, Vptr.I32); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_E8 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_E32 => + Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); + if not Is_Sig then + Update (32); + end if; + when Ghdl_Rtik_Type_B1 => + Disp_Enum_Value (Stream, Rti, + Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); + if not Is_Sig then + Update (8); + end if; + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Vptr.F64); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Vptr.I64); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (64); + end if; + when Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Vptr.I32); + Put (Stream, " "); + Put (Stream, + Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); + if not Is_Sig then + Update (32); + end if; + when others => + Internal_Error ("disp_rti.disp_scalar_value"); + end case; + end Disp_Scalar_Value; + +-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik +-- is +-- Ndef : Ghdl_Rti_Access; +-- begin +-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then +-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; +-- else +-- Ndef := Rti; +-- end if; +-- case Ndef.Kind is +-- when Ghdl_Rtik_Type_I32 => +-- return Ndef.Kind; +-- when others => +-- return Ghdl_Rtik_Error; +-- end case; +-- end Get_Scalar_Type_Kind; + + procedure Disp_Array_Value_1 (Stream : FILEs; + El_Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type; + Obj : in out Address; + Is_Sig : Boolean) + is + Length : Ghdl_Index_Type; + begin + Length := Range_To_Length (Rngs (Index), Get_Base_Type (Rtis (Index))); + Put (Stream, "("); + for I in 1 .. Length loop + if I /= 1 then + Put (Stream, ", "); + end if; + if Index = Rngs'Last then + Disp_Value (Stream, El_Rti, Ctxt, Obj, Is_Sig); + else + Disp_Array_Value_1 + (Stream, El_Rti, Ctxt, Rngs, Rtis, Index + 1, Obj, Is_Sig); + end if; + end loop; + Put (Stream, ")"); + end Disp_Array_Value_1; + + procedure Disp_Array_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Vals : Ghdl_Uc_Array_Acc; + Is_Sig : Boolean) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + Obj : Address; + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Obj := Vals.Base; + Disp_Array_Value_1 + (Stream, Rti.Element, Ctxt, Rngs, Rti.Indexes, 0, Obj, Is_Sig); + end Disp_Array_Value; + + procedure Disp_Record_Value (Stream : FILEs; + Rti : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Obj : Address; + Is_Sig : Boolean) + is + El : Ghdl_Rtin_Element_Acc; + El_Addr : Address; + begin + Put (Stream, "("); + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if I /= 1 then + Put (", "); + end if; + Put (Stream, El.Name); + Put (" => "); + if Is_Sig then + El_Addr := Obj + El.Sig_Off; + else + El_Addr := Obj + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + El_Addr := Obj + To_Ghdl_Index_Acc (El_Addr).all; + end if; + Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, Is_Sig); + end loop; + Put (")"); + -- FIXME: update ADDR. + end Disp_Record_Value; + + procedure Disp_Value + (Stream : FILEs; + Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Obj : in out Address; + Is_Sig : Boolean) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Disp_Scalar_Value + (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, + Obj, Is_Sig); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); + when Ghdl_Rtik_Type_Array => + Disp_Array_Value (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, + To_Ghdl_Uc_Array_Acc (Obj), Is_Sig); + when Ghdl_Rtik_Subtype_Array => + declare + St : constant Ghdl_Rtin_Subtype_Array_Acc := + To_Ghdl_Rtin_Subtype_Array_Acc (Rti); + Bt : constant Ghdl_Rtin_Type_Array_Acc := St.Basetype; + Rngs : Ghdl_Range_Array (0 .. Bt.Nbr_Dim - 1); + B : Address; + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + B := Obj; + Disp_Array_Value_1 + (Stream, Bt.Element, Ctxt, Rngs, Bt.Indexes, 0, B, Is_Sig); + end; + when Ghdl_Rtik_Type_File => + declare + Vptr : Ghdl_Value_Ptr; + begin + Vptr := To_Ghdl_Value_Ptr (Obj); + Put (Stream, "File#"); + Put_I32 (Stream, Vptr.I32); + -- FIXME: update OBJ (not very useful since never in a + -- composite type). + end; + when Ghdl_Rtik_Type_Record => + Disp_Record_Value + (Stream, To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Obj, Is_Sig); + when Ghdl_Rtik_Type_Protected => + Put (Stream, "Unhandled protected type"); + when others => + Put (Stream, "Unknown Rti Kind : "); + Disp_Kind(Rti.Kind); + end case; + -- Put_Line(":"); + end Disp_Value; + + procedure Disp_Kind (Kind : Ghdl_Rtik) is + begin + case Kind is + when Ghdl_Rtik_Top => + Put ("ghdl_rtik_top"); + when Ghdl_Rtik_Package => + Put ("ghdl_rtik_package"); + when Ghdl_Rtik_Package_Body => + Put ("ghdl_rtik_package_body"); + when Ghdl_Rtik_Entity => + Put ("ghdl_rtik_entity"); + when Ghdl_Rtik_Architecture => + Put ("ghdl_rtik_architecture"); + + when Ghdl_Rtik_Port => + Put ("ghdl_rtik_port"); + when Ghdl_Rtik_Generic => + Put ("ghdl_rtik_generic"); + when Ghdl_Rtik_Process => + Put ("ghdl_rtik_process"); + when Ghdl_Rtik_Component => + Put ("ghdl_rtik_component"); + when Ghdl_Rtik_Attribute => + Put ("ghdl_rtik_attribute"); + + when Ghdl_Rtik_Attribute_Quiet => + Put ("ghdl_rtik_attribute_quiet"); + when Ghdl_Rtik_Attribute_Stable => + Put ("ghdl_rtik_attribute_stable"); + when Ghdl_Rtik_Attribute_Transaction => + Put ("ghdl_rtik_attribute_transaction"); + + when Ghdl_Rtik_Constant => + Put ("ghdl_rtik_constant"); + when Ghdl_Rtik_Iterator => + Put ("ghdl_rtik_iterator"); + when Ghdl_Rtik_Signal => + Put ("ghdl_rtik_signal"); + when Ghdl_Rtik_Variable => + Put ("ghdl_rtik_variable"); + when Ghdl_Rtik_Guard => + Put ("ghdl_rtik_guard"); + when Ghdl_Rtik_File => + Put ("ghdl_rtik_file"); + + when Ghdl_Rtik_Instance => + Put ("ghdl_rtik_instance"); + when Ghdl_Rtik_Block => + Put ("ghdl_rtik_block"); + when Ghdl_Rtik_If_Generate => + Put ("ghdl_rtik_if_generate"); + when Ghdl_Rtik_For_Generate => + Put ("ghdl_rtik_for_generate"); + + when Ghdl_Rtik_Type_B1 => + Put ("ghdl_rtik_type_b1"); + when Ghdl_Rtik_Type_E8 => + Put ("ghdl_rtik_type_e8"); + when Ghdl_Rtik_Type_E32 => + Put ("ghdl_rtik_type_e32"); + when Ghdl_Rtik_Type_P64 => + Put ("ghdl_rtik_type_p64"); + when Ghdl_Rtik_Type_I32 => + Put ("ghdl_rtik_type_i32"); + + when Ghdl_Rtik_Type_Array => + Put ("ghdl_rtik_type_array"); + when Ghdl_Rtik_Subtype_Array => + Put ("ghdl_rtik_subtype_array"); + when Ghdl_Rtik_Type_Record => + Put ("ghdl_rtik_type_record"); + + when Ghdl_Rtik_Type_Access => + Put ("ghdl_rtik_type_access"); + when Ghdl_Rtik_Type_File => + Put ("ghdl_rtik_type_file"); + when Ghdl_Rtik_Type_Protected => + Put ("ghdl_rtik_type_protected"); + + when Ghdl_Rtik_Subtype_Scalar => + Put ("ghdl_rtik_subtype_scalar"); + + when Ghdl_Rtik_Element => + Put ("ghdl_rtik_element"); + when Ghdl_Rtik_Unit64 => + Put ("ghdl_rtik_unit64"); + when Ghdl_Rtik_Unitptr => + Put ("ghdl_rtik_unitptr"); + + when others => + Put ("ghdl_rtik_#"); + Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); + end case; + end Disp_Kind; + + procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is + begin + Put (", D="); + Put_I32 (stdout, Ghdl_I32 (Depth)); + end Disp_Depth; + + procedure Disp_Indent (Indent : Natural) is + begin + for I in 1 .. Indent loop + Put (' '); + end loop; + end Disp_Indent; + + -- Disp a subtype_indication. + -- OBJ may be necessary when the subtype is an unconstrained array type, + -- whose bounds are stored with the object. + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); + + procedure Disp_Range + (Stream : FILEs; Kind : Ghdl_Rtik; Rng : Ghdl_Range_Ptr) + is + begin + case Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_P32 => + Put_I32 (Stream, Rng.I32.Left); + Put_Dir (Stream, Rng.I32.Dir); + Put_I32 (Stream, Rng.I32.Right); + when Ghdl_Rtik_Type_F64 => + Put_F64 (Stream, Rng.F64.Left); + Put_Dir (Stream, Rng.F64.Dir); + Put_F64 (Stream, Rng.F64.Right); + when Ghdl_Rtik_Type_P64 => + Put_I64 (Stream, Rng.P64.Left); + Put_Dir (Stream, Rng.P64.Dir); + Put_I64 (Stream, Rng.P64.Right); + when others => + Put ("?Scal"); + end case; + end Disp_Range; + + procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Scalar_Type_Name (Rti.Basetype); + end if; + end; + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Put ("#disp_scalar_type_name#"); + end case; + end Disp_Scalar_Type_Name; + + procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; + Bounds_Ptr : Address) + is + Bounds : Address; + + procedure Align (A : Ghdl_Index_Type) is + begin + Bounds := Align (Bounds, Ghdl_Rti_Loc (A)); + end Align; + + procedure Update (S : Ghdl_Index_Type) is + begin + Bounds := Bounds + (S / Storage_Unit); + end Update; + + procedure Disp_Bounds (Def : Ghdl_Rti_Access) + is + Ndef : Ghdl_Rti_Access; + begin + if Bounds = Null_Address then + Put ("?"); + else + if Def.Kind = Ghdl_Rtik_Subtype_Scalar then + Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def).Basetype; + else + Ndef := Def; + end if; + case Ndef.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Disp_Range (stdout, Ndef.Kind, To_Ghdl_Range_Ptr (Bounds)); + Update (Ghdl_Range_I32'Size); + when others => + Disp_Kind (Ndef.Kind); + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end Disp_Bounds; + begin + Disp_Name (Def.Name); + if Bounds_Ptr = Null_Address then + return; + end if; + Put (" ("); + Bounds := Bounds_Ptr; + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Scalar_Type_Name (Def.Indexes (I)); + Put (" range "); + Disp_Bounds (Def.Indexes (I)); + end loop; + Put (")"); + end Disp_Type_Array_Name; + + procedure Disp_Subtype_Scalar_Range + (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) + is + Range_Addr : Address; + Rng : Ghdl_Range_Ptr; + begin + Range_Addr := Loc_To_Addr (Def.Common.Depth, + Def.Range_Loc, Ctxt); + Rng := To_Ghdl_Range_Ptr (Range_Addr); + Disp_Range (Stream, Def.Basetype.Kind, Rng); + end Disp_Subtype_Scalar_Range; + + procedure Disp_Subtype_Indication + (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) + is + begin + case Def.Kind is + when Ghdl_Rtik_Subtype_Scalar => + declare + Rti : Ghdl_Rtin_Subtype_Scalar_Acc; + begin + Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); + if Rti.Name /= null then + Disp_Name (Rti.Name); + else + Disp_Subtype_Indication + (Rti.Basetype, Null_Context, Null_Address); + Put (" range "); + Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); + end if; + end; + --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), + -- Base); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_I64 => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when Ghdl_Rtik_Type_File + | Ghdl_Rtik_Type_Access => + Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); + when Ghdl_Rtik_Type_Record => + Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); + when Ghdl_Rtik_Type_Array => + declare + Bounds : Address; + begin + if Obj = Null_Address then + Bounds := Null_Address; + else + Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; + end if; + Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), + Bounds); + end; + when Ghdl_Rtik_Subtype_Array => + declare + Sdef : Ghdl_Rtin_Subtype_Array_Acc; + begin + Sdef := To_Ghdl_Rtin_Subtype_Array_Acc (Def); + if Sdef.Name /= null then + Disp_Name (Sdef.Name); + else + Disp_Type_Array_Name + (Sdef.Basetype, + Loc_To_Addr (Sdef.Common.Depth, Sdef.Bounds, Ctxt)); + end if; + end; + when Ghdl_Rtik_Type_Protected => + Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); + when others => + Disp_Kind (Def.Kind); + Put (' '); + end case; + end Disp_Subtype_Indication; + + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural); + + procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; + Arr : Ghdl_Rti_Arr_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + for I in 1 .. Nbr loop + Disp_Rti (Arr (I - 1), Ctxt, Indent); + end loop; + end Disp_Rti_Arr; + + procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Blk.Common.Kind); + Disp_Depth (Blk.Common.Depth); + Put (": "); + Disp_Name (Blk.Name); + New_Line; + if Blk.Parent /= null then + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + -- Disp entity. + Disp_Rti (Blk.Parent, Ctxt, Indent + 1); + when others => + null; + end case; + end if; + case Blk.Common.Kind is + when Ghdl_Rtik_Package + | Ghdl_Rtik_Package_Body + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Block + | Ghdl_Rtik_Process => + Nctxt := (Base => Ctxt.Base + Blk.Loc, + Block => To_Ghdl_Rti_Access (Blk)); + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + when Ghdl_Rtik_For_Generate => + declare + Length : Ghdl_Index_Type; + begin + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + Length := Get_For_Generate_Length (Blk, Ctxt); + for I in 1 .. Length loop + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + Nctxt.Base := Nctxt.Base + Blk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Blk.Loc).all, + Block => To_Ghdl_Rti_Access (Blk)); + if Nctxt.Base /= Null_Address then + Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, + Nctxt, Indent + 1); + end if; + when others => + Internal_Error ("disp_block"); + end case; + end Disp_Block; + + procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; + Is_Sig : Boolean; + Ctxt : Rti_Context; + Indent : Natural) + is + Addr : Address; + Obj_Type : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); + Obj_Type := Obj.Obj_Type; + Disp_Subtype_Indication (Obj_Type, Ctxt, Addr); + Put (" := "); + + -- FIXME: put this into a function. + if (Obj_Type.Kind = Ghdl_Rtik_Subtype_Array + or Obj_Type.Kind = Ghdl_Rtik_Type_Record) + and then Rti_Complex_Type (Obj_Type) + then + Addr := To_Addr_Acc (Addr).all; + end if; + Disp_Value (stdout, Obj_Type, Ctxt, Addr, Is_Sig); + New_Line; + end Disp_Object; + + procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Obj.Common.Kind); + Disp_Depth (Obj.Common.Depth); + Put ("; "); + Disp_Name (Obj.Name); + Put (": "); + Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); + New_Line; + end Disp_Attribute; + + procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Comp.Common.Kind); + Disp_Depth (Comp.Common.Depth); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); + end Disp_Component; + + procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Inst_Addr : Address; + Inst_Base : Address; + Inst_Rti : Ghdl_Rti_Access; + Nindent : Natural; + Nctxt : Rti_Context; + begin + Disp_Indent (Indent); + Disp_Kind (Inst.Common.Kind); + Put (": "); + Disp_Name (Inst.Name); + New_Line; + + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + + Nindent := Indent + 1; + + case Inst.Instance.Kind is + when Ghdl_Rtik_Component => + declare + Comp : Ghdl_Rtin_Component_Acc; + begin + Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); + Disp_Indent (Nindent); + Disp_Kind (Comp.Common.Kind); + Put (": "); + Disp_Name (Comp.Name); + New_Line; + -- Disp components generics and ports. + -- FIXME: the data to disp are at COMP_BASE. + Nctxt := (Base => Inst_Addr, + Block => Inst.Instance); + Nindent := Nindent + 1; + Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); + Nindent := Nindent + 1; + end; + when Ghdl_Rtik_Entity => + null; + when others => + null; + end case; + + -- Read instance RTI. + if Inst_Base /= Null_Address then + Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; + Nctxt := (Base => Inst_Base, + Block => Inst_Rti); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), + Nctxt, Nindent); + end if; + end Disp_Instance; + + procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Enum.Common.Kind); + Put (": "); + Disp_Name (Enum.Name); + Put (" is ("); + Disp_Name (Enum.Names (0)); + for I in 1 .. Enum.Nbr - 1 loop + Put (", "); + Disp_Name (Enum.Names (I)); + end loop; + Put (")"); + New_Line; + end Disp_Type_Enum_Decl; + + procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Bt : Ghdl_Rti_Access; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Disp_Depth (Def.Common.Depth); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Bt := Def.Basetype; + case Bt.Kind is + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_F64 => + declare + Bdef : Ghdl_Rtin_Type_Scalar_Acc; + begin + Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + end; + when Ghdl_Rtik_Type_P64 + | Ghdl_Rtik_Type_P32 => + declare + Bdef : Ghdl_Rtin_Type_Physical_Acc; + Unit : Ghdl_Rti_Access; + begin + Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); + if Bdef.Name /= Def.Name then + Disp_Name (Bdef.Name); + Put (" range "); + end if; + -- This is the type definition. + Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); + if Bdef.Name = Def.Name then + for I in 0 .. Bdef.Nbr - 1 loop + Unit := Bdef.Units (I); + New_Line; + Disp_Indent (Indent + 1); + Disp_Kind (Unit.Kind); + Put (": "); + Disp_Name (Get_Physical_Unit_Name (Unit)); + Put (" = "); + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + Put_I64 (stdout, + To_Ghdl_Rtin_Unit64_Acc (Unit).Value); + when Ghdl_Rtik_Unitptr => + case Bt.Kind is + when Ghdl_Rtik_Type_P64 => + Put_I64 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); + when Ghdl_Rtik_Type_P32 => + Put_I32 + (stdout, + To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + when others => + Internal_Error + ("disp_rti.subtype.scalar_decl(P32/P64)"); + end case; + end loop; + end if; + end; + when others => + Disp_Subtype_Indication + (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); + end case; + New_Line; + end Disp_Subtype_Scalar_Decl; + + procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is array ("); + for I in 0 .. Def.Nbr_Dim - 1 loop + if I /= 0 then + Put (", "); + end if; + Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); + Put (" range <>"); + end loop; + Put (") of "); + Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); + New_Line; + end Disp_Type_Array_Decl; + + procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Array_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + Basetype : constant Ghdl_Rtin_Type_Array_Acc := Def.Basetype; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + Disp_Type_Array_Name + (Basetype, Loc_To_Addr (Def.Common.Depth, Def.Bounds, Ctxt)); + if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then + Put (" of "); + Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); + end if; + New_Line; + end Disp_Subtype_Array_Decl; + + procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is "); + case Def.Common.Kind is + when Ghdl_Rtik_Type_Access => + Put ("access "); + when Ghdl_Rtik_Type_File => + Put ("file "); + when others => + Put ("?? "); + end case; + Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); + New_Line; + end Disp_Type_File_Or_Access; + + procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + El : Ghdl_Rtin_Element_Acc; + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is record"); + New_Line; + for I in 1 .. Def.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); + Disp_Indent (Indent + 1); + Disp_Kind (El.Common.Kind); + Put (": "); + Disp_Name (El.Name); + Put (": "); + Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); + New_Line; + end loop; + end Disp_Type_Record; + + procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; + Ctxt : Rti_Context; + Indent : Natural) + is + pragma Unreferenced (Ctxt); + begin + Disp_Indent (Indent); + Disp_Kind (Def.Common.Kind); + Put (": "); + Disp_Name (Def.Name); + Put (" is protected"); + New_Line; + end Disp_Type_Protected; + + procedure Disp_Rti (Rti : Ghdl_Rti_Access; + Ctxt : Rti_Context; + Indent : Natural) + is + begin + if Rti = null then + return; + end if; + + case Rti.Kind is + when Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture + | Ghdl_Rtik_Package + | Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate + | Ghdl_Rtik_For_Generate => + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Package_Body => + Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); + Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); + when Ghdl_Rtik_Generic + | Ghdl_Rtik_Constant + | Ghdl_Rtik_Variable + | Ghdl_Rtik_Iterator + | Ghdl_Rtik_File => + Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); + when Ghdl_Rtik_Component => + Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); + when Ghdl_Rtik_Attribute => + Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Instance => + Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_B1 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 => + Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); + when Ghdl_Rtik_Subtype_Scalar => + Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), + Ctxt, Indent); + when Ghdl_Rtik_Type_Array => + Disp_Type_Array_Decl + (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Subtype_Array => + Disp_Subtype_Array_Decl + (To_Ghdl_Rtin_Subtype_Array_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Access + | Ghdl_Rtik_Type_File => + Disp_Type_File_Or_Access + (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Record => + Disp_Type_Record + (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); + when Ghdl_Rtik_Type_Protected => + Disp_Type_Protected + (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); + when others => + Disp_Indent (Indent); + Disp_Kind (Rti.Kind); + Put_Line (" ? "); + 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.Common.Kind); + New_Line; + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, + Ghdl_Rti_Top.Children, + Ctxt, 0); + Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); + + --Disp_Hierarchy; + end Disp_All; + + function Disp_Rti_Option (Opt : String) return Boolean + is + begin + if Opt = "--dump-rti" then + Disp_Rti_Flag := True; + return True; + else + return False; + end if; + end Disp_Rti_Option; + + procedure Disp_Rti_Help + is + procedure P (Str : String) renames Put_Line; + begin + P (" --dump-rti dump Run Time Information"); + end Disp_Rti_Help; + + 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 Register is + begin + Register_Hooks (Disp_Rti_Hooks'Access); + end Register; + +end Grt.Disp_Rti; |