diff options
Diffstat (limited to 'src/translate/grt/grt-rtis_utils.adb')
| -rw-r--r-- | src/translate/grt/grt-rtis_utils.adb | 660 |
1 files changed, 660 insertions, 0 deletions
diff --git a/src/translate/grt/grt-rtis_utils.adb b/src/translate/grt/grt-rtis_utils.adb new file mode 100644 index 0000000..0d4328e --- /dev/null +++ b/src/translate/grt/grt-rtis_utils.adb @@ -0,0 +1,660 @@ +-- GHDL Run Time (GRT) - RTI utilities. +-- 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.Disp; use Grt.Disp; +with Grt.Errors; use Grt.Errors; + +package body Grt.Rtis_Utils is + + function Traverse_Blocks (Ctxt : Rti_Context) return Traverse_Result + is + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result; + + function Traverse_Blocks_1 (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + Index : Ghdl_Index_Type; + Child : Ghdl_Rti_Access; + begin + Res := Process (Ctxt, Ctxt.Block); + if Res /= Traverse_Ok then + return Res; + end if; + + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + Index := 0; + while Index < Blk.Nbr_Child loop + Child := Blk.Children (Index); + Index := Index + 1; + case Child.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := (Base => Ctxt.Base + Nblk.Loc, + Block => Child); + Res := Traverse_Blocks_1 (Nctxt); + end; + when Ghdl_Rtik_For_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + Length : Ghdl_Index_Type; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + Length := Get_For_Generate_Length (Nblk, Ctxt); + for I in 1 .. Length loop + Res := Traverse_Blocks_1 (Nctxt); + exit when Res = Traverse_Stop; + Nctxt.Base := Nctxt.Base + Nblk.Size; + end loop; + end; + when Ghdl_Rtik_If_Generate => + declare + Nblk : Ghdl_Rtin_Block_Acc; + begin + Nblk := To_Ghdl_Rtin_Block_Acc (Child); + Nctxt := + (Base => To_Addr_Acc (Ctxt.Base + Nblk.Loc).all, + Block => Child); + if Nctxt.Base /= Null_Address then + Res := Traverse_Blocks_1 (Nctxt); + end if; + end; + when Ghdl_Rtik_Instance => + Res := Process (Ctxt, Child); + if Res = Traverse_Ok then + declare + Obj : Ghdl_Rtin_Instance_Acc; + begin + Obj := To_Ghdl_Rtin_Instance_Acc (Child); + + Get_Instance_Context (Obj, Ctxt, Nctxt); + if Nctxt /= Null_Context then + Res := Traverse_Instance (Nctxt); + end if; + end; + end if; + when Ghdl_Rtik_Package + | Ghdl_Rtik_Entity + | Ghdl_Rtik_Architecture => + Internal_Error ("traverse_blocks"); + when Ghdl_Rtik_Port + | Ghdl_Rtik_Signal + | Ghdl_Rtik_Guard + | Ghdl_Rtik_Attribute_Quiet + | Ghdl_Rtik_Attribute_Stable + | Ghdl_Rtik_Attribute_Transaction => + Res := Process (Ctxt, Child); + when others => + null; + end case; + exit when Res = Traverse_Stop; + end loop; + + return Res; + end Traverse_Blocks_1; + + function Traverse_Instance (Ctxt : Rti_Context) return Traverse_Result + is + Blk : Ghdl_Rtin_Block_Acc; + + Res : Traverse_Result; + Nctxt : Rti_Context; + + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Blk.Common.Kind is + when Ghdl_Rtik_Architecture => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + -- The entity. + Res := Traverse_Blocks_1 (Nctxt); + if Res /= Traverse_Stop then + -- The architecture. + Res := Traverse_Blocks_1 (Ctxt); + end if; + when Ghdl_Rtik_Package_Body => + Nctxt := (Base => Ctxt.Base, + Block => Blk.Parent); + Res := Traverse_Blocks_1 (Nctxt); + when others => + Internal_Error ("traverse_blocks"); + end case; + return Res; + end Traverse_Instance; + begin + return Traverse_Instance (Ctxt); + end Traverse_Blocks; + + -- Disp value stored at ADDR and whose type is described by RTI. + procedure Get_Enum_Value + (Vstr : in out Vstring; 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); + Append (Vstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Foreach_Scalar (Ctxt : Rti_Context; + Obj_Type : Ghdl_Rti_Access; + Obj_Addr : Address; + Is_Sig : Boolean; + Param : Param_Type) + is + -- Current address. + Addr : Address; + + Name : Vstring; + + procedure Handle_Any (Rti : Ghdl_Rti_Access); + + procedure Handle_Scalar (Rti : Ghdl_Rti_Access) + is + procedure Update (S : Ghdl_Index_Type) is + begin + Addr := Addr + (S / Storage_Unit); + end Update; + begin + Process (Addr, Name, Rti, Param); + + if Is_Sig then + Update (Address'Size); + else + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + Update (32); + when Ghdl_Rtik_Type_E8 => + Update (8); + when Ghdl_Rtik_Type_E32 => + Update (32); + when Ghdl_Rtik_Type_B1 => + Update (8); + when Ghdl_Rtik_Type_F64 => + Update (64); + when Ghdl_Rtik_Type_P64 => + Update (64); + when others => + Internal_Error ("handle_scalar"); + end case; + end if; + end Handle_Scalar; + + procedure Range_Pos_To_Val (Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type; + Val : out Value_Union) + is + begin + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + case Rng.I32.Dir is + when Dir_To => + Val.I32 := Rng.I32.Left + Ghdl_I32 (Pos); + when Dir_Downto => + Val.I32 := Rng.I32.Left - Ghdl_I32 (Pos); + end case; + when Ghdl_Rtik_Type_E8 => + case Rng.E8.Dir is + when Dir_To => + Val.E8 := Rng.E8.Left + Ghdl_E8 (Pos); + when Dir_Downto => + Val.E8 := Rng.E8.Left - Ghdl_E8 (Pos); + end case; + when Ghdl_Rtik_Type_E32 => + case Rng.E32.Dir is + when Dir_To => + Val.E32 := Rng.E32.Left + Ghdl_E32 (Pos); + when Dir_Downto => + Val.E32 := Rng.E32.Left - Ghdl_E32 (Pos); + end case; + when Ghdl_Rtik_Type_B1 => + case Pos is + when 0 => + Val.B1 := Rng.B1.Left; + when 1 => + Val.B1 := Rng.B1.Right; + when others => + Val.B1 := False; + end case; + when others => + Internal_Error ("grt.rtis_utils.range_pos_to_val"); + end case; + end Range_Pos_To_Val; + + procedure Pos_To_Vstring + (Vstr : in out Vstring; + Rti : Ghdl_Rti_Access; + Rng : Ghdl_Range_Ptr; + Pos : Ghdl_Index_Type) + is + V : Value_Union; + begin + Range_Pos_To_Val (Rti, Rng, Pos, V); + case Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, V.I32); + Append (Vstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Vstr, Rti, Ghdl_Index_Type (V.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value (Vstr, Rti, Ghdl_B1'Pos (V.B1)); + when others => + Append (Vstr, '?'); + end case; + end Pos_To_Vstring; + + procedure Handle_Array_1 (El_Rti : Ghdl_Rti_Access; + Rngs : Ghdl_Range_Array; + Rtis : Ghdl_Rti_Arr_Acc; + Index : Ghdl_Index_Type) + is + Len : Ghdl_Index_Type; + P : Natural; + Base_Type : Ghdl_Rti_Access; + begin + P := Length (Name); + if Index = 0 then + Append (Name, '('); + else + Append (Name, ','); + end if; + + Base_Type := Get_Base_Type (Rtis (Index)); + Len := Range_To_Length (Rngs (Index), Base_Type); + + for I in 1 .. Len loop + Pos_To_Vstring (Name, Base_Type, Rngs (Index), I - 1); + if Index = Rngs'Last then + Append (Name, ')'); + Handle_Any (El_Rti); + else + Handle_Array_1 (El_Rti, Rngs, Rtis, Index + 1); + end if; + Truncate (Name, P + 1); + end loop; + Truncate (Name, P); + end Handle_Array_1; + + procedure Handle_Array (Rti : Ghdl_Rtin_Type_Array_Acc; + Vals : Ghdl_Uc_Array_Acc) + is + Nbr_Dim : constant Ghdl_Index_Type := Rti.Nbr_Dim; + Rngs : Ghdl_Range_Array (0 .. Nbr_Dim - 1); + begin + Bound_To_Range (Vals.Bounds, Rti, Rngs); + Addr := Vals.Base; + Handle_Array_1 (Rti.Element, Rngs, Rti.Indexes, 0); + end Handle_Array; + + procedure Handle_Record (Rti : Ghdl_Rtin_Type_Record_Acc) + is + El : Ghdl_Rtin_Element_Acc; + Obj_Addr : Address; + Last_Addr : Address; + P : Natural; + begin + P := Length (Name); + Obj_Addr := Addr; + Last_Addr := Addr; + for I in 1 .. Rti.Nbrel loop + El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); + if Is_Sig then + Addr := Obj_Addr + El.Sig_Off; + else + Addr := Obj_Addr + El.Val_Off; + end if; + if Rti_Complex_Type (El.Eltype) then + Addr := Obj_Addr + To_Ghdl_Index_Acc (Addr).all; + end if; + Append (Name, '.'); + Append (Name, El.Name); + Handle_Any (El.Eltype); + if Addr > Last_Addr then + Last_Addr := Addr; + end if; + Truncate (Name, P); + end loop; + Addr := Last_Addr; + end Handle_Record; + + procedure Handle_Any (Rti : Ghdl_Rti_Access) is + begin + case Rti.Kind is + when Ghdl_Rtik_Subtype_Scalar => + Handle_Scalar (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype); + when Ghdl_Rtik_Type_I32 + | Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + Handle_Scalar (Rti); + when Ghdl_Rtik_Type_Array => + Handle_Array (To_Ghdl_Rtin_Type_Array_Acc (Rti), + To_Ghdl_Uc_Array_Acc (Addr)); + 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); + begin + Bound_To_Range + (Loc_To_Addr (St.Common.Depth, St.Bounds, Ctxt), Bt, Rngs); + Handle_Array_1 (Bt.Element, Rngs, Bt.Indexes, 0); + 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 => + Handle_Record (To_Ghdl_Rtin_Type_Record_Acc (Rti)); + when others => + Internal_Error ("grt.rtis_utils.foreach_scalar.handle_any"); + end case; + end Handle_Any; + begin + if Rti_Complex_Type (Obj_Type) then + Addr := To_Addr_Acc (Obj_Addr).all; + else + Addr := Obj_Addr; + end if; + Handle_Any (Obj_Type); + Free (Name); + end Foreach_Scalar; + + procedure Get_Value (Str : in out Vstring; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Str, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Str, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when Ghdl_Rtik_Type_F64 => + declare + S : String (1 .. 32); + L : Integer; + + function Snprintf_G (Cstr : Address; + Size : Natural; + Arg : Ghdl_F64) + return Integer; + pragma Import (C, Snprintf_G, "__ghdl_snprintf_g"); + + begin + L := Snprintf_G (S'Address, S'Length, Value.F64); + if L < 0 then + -- FIXME. + Append (Str, "?"); + else + Append (Str, S (1 .. L)); + end if; + end; + when Ghdl_Rtik_Type_P32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when Ghdl_Rtik_Type_P64 => + declare + S : String (1 .. 21); + F : Natural; + begin + To_String (S, F, Value.I64); + Append (Str, S (F .. S'Last)); + Append + (Str, Get_Physical_Unit_Name + (To_Ghdl_Rtin_Type_Physical_Acc (Type_Rti).Units (0))); + end; + when others => + Internal_Error ("grt.rtis_utils.get_value"); + end case; + end Get_Value; + + procedure Disp_Value (Stream : FILEs; + Value : Value_Union; + Type_Rti : Ghdl_Rti_Access) + is + Name : Vstring; + begin + Rtis_Utils.Get_Value (Name, Value, Type_Rti); + Put (Stream, Name); + Free (Name); + end Disp_Value; + + function Get_Physical_Unit_Name (Unit : Ghdl_Rti_Access) + return Ghdl_C_String + is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Name; + when Ghdl_Rtik_Unitptr => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Name; + when others => + Internal_Error ("rtis_utils.physical_unit_name"); + end case; + end Get_Physical_Unit_Name; + + function Get_Physical_Unit_Value (Unit : Ghdl_Rti_Access; + Type_Rti : Ghdl_Rti_Access) + return Ghdl_I64 is + begin + case Unit.Kind is + when Ghdl_Rtik_Unit64 => + return To_Ghdl_Rtin_Unit64_Acc (Unit).Value; + when Ghdl_Rtik_Unitptr => + case Type_Rti.Kind is + when Ghdl_Rtik_Type_P64 => + return To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64; + when Ghdl_Rtik_Type_P32 => + return Ghdl_I64 + (To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); + when others => + Internal_Error ("get_physical_unit_value(1)"); + end case; + when others => + Internal_Error ("get_physical_unit_value(2)"); + end case; + end Get_Physical_Unit_Value; + + procedure Get_Enum_Value + (Rstr : in out Rstring; 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); + Prepend (Rstr, Enum_Rti.Names (Val)); + end Get_Enum_Value; + + + procedure Get_Value (Rstr : in out Rstring; + Addr : Address; + Type_Rti : Ghdl_Rti_Access) + is + Value : constant Ghdl_Value_Ptr := To_Ghdl_Value_Ptr (Addr); + begin + case Type_Rti.Kind is + when Ghdl_Rtik_Type_I32 => + declare + S : String (1 .. 12); + F : Natural; + begin + To_String (S, F, Value.I32); + Prepend (Rstr, S (F .. S'Last)); + end; + when Ghdl_Rtik_Type_E8 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E8)); + when Ghdl_Rtik_Type_E32 => + Get_Enum_Value (Rstr, Type_Rti, Ghdl_Index_Type (Value.E32)); + when Ghdl_Rtik_Type_B1 => + Get_Enum_Value + (Rstr, Type_Rti, Ghdl_Index_Type (Ghdl_B1'Pos (Value.B1))); + when others => + Internal_Error ("grt.rtis_utils.get_value(rstr)"); + end case; + end Get_Value; + + procedure Get_Path_Name (Rstr : in out Rstring; + Last_Ctxt : Rti_Context; + Sep : Character; + Is_Instance : Boolean := True) + is + Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context; + begin + Ctxt := Last_Ctxt; + loop + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block + | Ghdl_Rtik_If_Generate => + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + when Ghdl_Rtik_Entity => + declare + Link : Ghdl_Entity_Link_Acc; + begin + Link := To_Ghdl_Entity_Link_Acc (Ctxt.Base); + Ctxt := (Base => Ctxt.Base, + Block => Link.Rti); + if Ctxt.Block = null then + -- Process in an entity. + -- FIXME: check. + Prepend (Rstr, Blk.Name); + return; + end if; + end; + when Ghdl_Rtik_Architecture => + declare + Entity_Ctxt: Rti_Context; + Link : Ghdl_Entity_Link_Acc; + Parent_Inst : Ghdl_Rti_Access; + begin + -- Architecture name. + if Is_Instance then + Prepend (Rstr, ')'); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, '('); + end if; + + Entity_Ctxt := Get_Parent_Context (Ctxt); + + -- Instance parent. + Link := To_Ghdl_Entity_Link_Acc (Entity_Ctxt.Base); + Get_Instance_Link (Link, Ctxt, Parent_Inst); + + -- Add entity name. + if Is_Instance or Parent_Inst = null then + Prepend (Rstr, + To_Ghdl_Rtin_Block_Acc (Entity_Ctxt.Block).Name); + end if; + + if Parent_Inst = null then + -- Top reached. + Prepend (Rstr, Sep); + return; + else + -- Instantiation statement label. + if Is_Instance then + Prepend (Rstr, '@'); + end if; + Prepend (Rstr, + To_Ghdl_Rtin_Object_Acc (Parent_Inst).Name); + Prepend (Rstr, Sep); + end if; + end; + when Ghdl_Rtik_For_Generate => + declare + Iter : Ghdl_Rtin_Object_Acc; + Addr : Address; + begin + Prepend (Rstr, ')'); + Iter := To_Ghdl_Rtin_Object_Acc (Blk.Children (0)); + Addr := Loc_To_Addr (Iter.Common.Depth, Iter.Loc, Ctxt); + Get_Value (Rstr, Addr, Get_Base_Type (Iter.Obj_Type)); + Prepend (Rstr, '('); + Prepend (Rstr, Blk.Name); + Prepend (Rstr, Sep); + Ctxt := Get_Parent_Context (Ctxt); + end; + when others => + Internal_Error ("grt.rtis_utils.get_path_name"); + end case; + end loop; + end Get_Path_Name; + + procedure Put (Stream : FILEs; Ctxt : Rti_Context) + is + Rstr : Rstring; + begin + Get_Path_Name (Rstr, Ctxt, '.'); + Put (Stream, Rstr); + Free (Rstr); + end Put; + +end Grt.Rtis_Utils; |