grt-rtis_addr.adb

vhdl集成电路设计软件.需要用gcc-4.0.2版本编译.

--  GHDL Run Time (GRT) -  RTI address handling.
--  Copyright (C) 2002, 2003, 2004, 2005 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.
with Ada.Unchecked_Conversion;
with Grt.Errors; use Grt.Errors;

package body Grt.Rtis_Addr is
   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_Index_Type) return Address
   is
   begin
      return To_Address (To_Integer (L) - Integer_Address (R));
   end "-";

   function Align (L : Address; R : Ghdl_Index_Type) return Address
   is
      Nad : Integer_Address;
   begin
      Nad := To_Integer (L + (R - 1));
      return To_Address (Nad - (Nad mod Integer_Address (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.Off,
                    Block => Blk.Parent);
         when Ghdl_Rtik_Architecture =>
            if Blk.Loc.Off /= 0 then
               Internal_Error ("get_parent_context(3)");
            end if;
            return (Base => Ctxt.Base + Blk.Loc.Off,
                    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.Off;
                        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.Off,
                  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 Loc.Addr;
      elsif Ctxt.Block.Depth = Depth then
         --Addr := Base + Storage_Offset (Obj.Loc.Off);
         return Ctxt.Base + Loc.Off;
      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.Off;
            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_B2 =>
            return Rng.B2.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.Off;
      --  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, 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 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_B2 =>
            return Atype;
         when others =>
            Internal_Error ("rtis_addr.get_base_type");
      end case;
   end Get_Base_Type;

   function Get_Top_Context return Rti_Context
   is
      Ctxt : Rti_Context;
   begin
      Ctxt := (Base => To_Address (Ghdl_Rti_Top_Instance),
               Block => Ghdl_Rti_Top_Ptr.Parent);
      return Ctxt;
   end Get_Top_Context;

end Grt.Rtis_Addr;