diff options
Diffstat (limited to 'src/grt/grt-rtis_addr.adb')
| -rw-r--r-- | src/grt/grt-rtis_addr.adb | 299 |
1 files changed, 299 insertions, 0 deletions
diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb new file mode 100644 index 0000000..70a0e21 --- /dev/null +++ b/src/grt/grt-rtis_addr.adb @@ -0,0 +1,299 @@ +-- GHDL Run Time (GRT) - RTI address handling. +-- 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.Errors; use Grt.Errors; + +package body Grt.Rtis_Addr is + function "+" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) + R); + end "+"; + + function "+" (L : Address; R : Ghdl_Index_Type) return Address + is + begin + return To_Address (To_Integer (L) + Integer_Address (R)); + end "+"; + + function "-" (L : Address; R : Ghdl_Rti_Loc) return Address + is + begin + return To_Address (To_Integer (L) - R); + end "-"; + + function Align (L : Address; R : Ghdl_Rti_Loc) return Address + is + Nad : Integer_Address; + begin + Nad := To_Integer (L + (R - 1)); + return To_Address (Nad - (Nad mod R)); + end Align; + + function Get_Parent_Context (Ctxt : Rti_Context) return Rti_Context + is + Blk : Ghdl_Rtin_Block_Acc; + begin + Blk := To_Ghdl_Rtin_Block_Acc (Ctxt.Block); + case Ctxt.Block.Kind is + when Ghdl_Rtik_Process + | Ghdl_Rtik_Block => + return (Base => Ctxt.Base - Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_Architecture => + if Blk.Loc /= Null_Rti_Loc then + Internal_Error ("get_parent_context(3)"); + end if; + return (Base => Ctxt.Base + Blk.Loc, + Block => Blk.Parent); + when Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + declare + Nbase : Address; + Parent : Ghdl_Rti_Access; + Blk1 : Ghdl_Rtin_Block_Acc; + begin + -- Read the pointer to the parent. + -- This is the first field. + Nbase := To_Addr_Acc (Ctxt.Base).all; + -- Since the parent may be a grant-parent, adjust + -- the base. + Parent := Blk.Parent; + loop + case Parent.Kind is + when Ghdl_Rtik_Architecture + | Ghdl_Rtik_For_Generate + | Ghdl_Rtik_If_Generate => + exit; + when Ghdl_Rtik_Block => + Blk1 := To_Ghdl_Rtin_Block_Acc (Parent); + Nbase := Nbase + Blk1.Loc; + Parent := Blk1.Parent; + when others => + Internal_Error ("get_parent_context(2)"); + end case; + end loop; + return (Base => Nbase, + Block => Blk.Parent); + end; + when others => + Internal_Error ("get_parent_context(1)"); + end case; + end Get_Parent_Context; + + procedure Get_Instance_Link (Link : Ghdl_Entity_Link_Acc; + Ctxt : out Rti_Context; + Stmt : out Ghdl_Rti_Access) + is + Obj : Ghdl_Rtin_Instance_Acc; + begin + if Link.Parent = null then + -- Top entity. + Stmt := null; + Ctxt := (Base => Null_Address, Block => null); + else + Stmt := Link.Parent.Stmt; + Obj := To_Ghdl_Rtin_Instance_Acc (Stmt); + Ctxt := (Base => Link.Parent.all'Address - Obj.Loc, + Block => Obj.Parent); + end if; + end Get_Instance_Link; + + function Loc_To_Addr (Depth : Ghdl_Rti_Depth; + Loc : Ghdl_Rti_Loc; + Ctxt : Rti_Context) + return Address + is + Cur_Ctxt : Rti_Context; + Nctxt : Rti_Context; + begin + if Depth = 0 then + return To_Address (Loc); + elsif Ctxt.Block.Depth = Depth then + --Addr := Base + Storage_Offset (Obj.Loc.Off); + return Ctxt.Base + Loc; + else + if Ctxt.Block.Depth < Depth then + Internal_Error ("loc_to_addr"); + end if; + Cur_Ctxt := Ctxt; + loop + Nctxt := Get_Parent_Context (Cur_Ctxt); + if Nctxt.Block.Depth = Depth then + return Nctxt.Base + Loc; + end if; + Cur_Ctxt := Nctxt; + end loop; + end if; + end Loc_To_Addr; + + function Range_To_Length (Rng : Ghdl_Range_Ptr; Base_Type : Ghdl_Rti_Access) + return Ghdl_Index_Type + is + begin + case Base_Type.Kind is + when Ghdl_Rtik_Type_B1 => + return Rng.B1.Len; + when Ghdl_Rtik_Type_E8 => + return Rng.E8.Len; + when Ghdl_Rtik_Type_E32 => + return Rng.E32.Len; + when Ghdl_Rtik_Type_I32 => + return Rng.I32.Len; + when others => + Internal_Error ("range_to_length"); + end case; + end Range_To_Length; + + function Get_For_Generate_Length (Blk : Ghdl_Rtin_Block_Acc; + Ctxt : Rti_Context) + return Ghdl_Index_Type + is + Iter_Type : Ghdl_Rtin_Subtype_Scalar_Acc; + Rng : Ghdl_Range_Ptr; + begin + Iter_Type := To_Ghdl_Rtin_Subtype_Scalar_Acc + (To_Ghdl_Rtin_Object_Acc (Blk.Children (0)).Obj_Type); + if Iter_Type.Common.Kind /= Ghdl_Rtik_Subtype_Scalar then + Internal_Error ("get_for_generate_length(1)"); + end if; + Rng := To_Ghdl_Range_Ptr + (Loc_To_Addr (Iter_Type.Common.Depth, Iter_Type.Range_Loc, Ctxt)); + return Range_To_Length (Rng, Iter_Type.Basetype); + end Get_For_Generate_Length; + + procedure Get_Instance_Context (Inst : Ghdl_Rtin_Instance_Acc; + Ctxt : Rti_Context; + Sub_Ctxt : out Rti_Context) + is + Inst_Addr : Address; + Inst_Base : Address; + begin + -- Address of the field containing the address of the instance. + Inst_Addr := Ctxt.Base + Inst.Loc; + -- Read sub instance address. + Inst_Base := To_Addr_Acc (Inst_Addr).all; + -- Read instance RTI. + if Inst_Base = Null_Address then + Sub_Ctxt := (Base => Null_Address, Block => null); + else + Sub_Ctxt := (Base => Inst_Base, + Block => To_Ghdl_Rti_Acc_Acc (Inst_Base).all); + end if; + end Get_Instance_Context; + + procedure Bound_To_Range (Bounds_Addr : Address; + Def : Ghdl_Rtin_Type_Array_Acc; + Res : out Ghdl_Range_Array) + 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; + + Idx_Def : Ghdl_Rti_Access; + begin + if Res'Length /= Def.Nbr_Dim or else Res'First /= 0 then + Internal_Error ("disp_rti.bound_to_range"); + end if; + + Bounds := Bounds_Addr; + + for I in 0 .. Def.Nbr_Dim - 1 loop + Idx_Def := Def.Indexes (I); + + if Bounds = Null_Address then + Res (I) := null; + else + Idx_Def := Get_Base_Type (Idx_Def); + case Idx_Def.Kind is + when Ghdl_Rtik_Type_I32 => + Align (Ghdl_Range_I32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_I32'Size); + when Ghdl_Rtik_Type_E8 => + Align (Ghdl_Range_E8'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E8'Size); + when Ghdl_Rtik_Type_E32 => + Align (Ghdl_Range_E32'Alignment); + Res (I) := To_Ghdl_Range_Ptr (Bounds); + Update (Ghdl_Range_E32'Size); + when others => + -- Bounds are not known anymore. + Bounds := Null_Address; + end case; + end if; + end loop; + end Bound_To_Range; + + function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access + is + begin + case Atype.Kind is + when Ghdl_Rtik_Subtype_Scalar => + return To_Ghdl_Rtin_Subtype_Scalar_Acc (Atype).Basetype; + when Ghdl_Rtik_Subtype_Array => + return To_Ghdl_Rti_Access + (To_Ghdl_Rtin_Subtype_Array_Acc (Atype).Basetype); + when Ghdl_Rtik_Type_E8 + | Ghdl_Rtik_Type_E32 + | Ghdl_Rtik_Type_B1 => + return Atype; + when others => + Internal_Error ("rtis_addr.get_base_type"); + end case; + end Get_Base_Type; + + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) + = Ghdl_Rti_Type_Complex; + end Rti_Complex_Type; + + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean + is + begin + return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) + = Ghdl_Rti_Type_Anonymous; + end Rti_Anonymous_Type; + + function Get_Top_Context return Rti_Context + is + Ctxt : Rti_Context; + begin + Ctxt := (Base => Ghdl_Rti_Top_Instance, + Block => Ghdl_Rti_Top.Parent); + return Ctxt; + end Get_Top_Context; + +end Grt.Rtis_Addr; |