-- GHDL Run Time (GRT) - RTI address handling.
-- Copyright (C) 2002 - 2014 Tristan Gingold
--
-- This program 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 of the License, or
-- (at your option) any later version.
--
-- This program 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 this program. If not, see <gnu.org/licenses>.
--
-- 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 : constant Ghdl_Rtin_Block_Acc :=
To_Ghdl_Rtin_Block_Acc (Ctxt.Block);
begin
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_Generate_Body =>
declare
Nbase : Address;
Nblk : Ghdl_Rti_Access;
Parent : Ghdl_Rti_Access;
begin
-- Read the pointer to the parent.
-- This is the first field.
Nbase := To_Addr_Acc (Ctxt.Base).all;
-- Parent (by default).
Nblk := Blk.Parent;
-- Since the parent may be a grant-parent, adjust
-- the base (so that the substraction above will work).
Parent := Blk.Parent;
loop
case Parent.Kind is
when Ghdl_Rtik_Architecture
| Ghdl_Rtik_Generate_Body =>
exit;
when Ghdl_Rtik_Block =>
declare
Blk1 : constant Ghdl_Rtin_Block_Acc :=
To_Ghdl_Rtin_Block_Acc (Parent);
begin
Nbase := Nbase + Blk1.Loc;
Parent := Blk1.Parent;
end;
when Ghdl_Rtik_For_Generate
| Ghdl_Rtik_If_Generate =>
declare
Gen : constant Ghdl_Rtin_Generate_Acc :=
To_Ghdl_Rtin_Generate_Acc (Parent);
begin
Parent := Gen.Parent;
-- For/If generate statement are not blocks. Skip
-- them.
Nblk := Gen.Parent;
end;
when others =>
Internal_Error ("get_parent_context(2)");
end case;
end loop;
return (Base => Nbase,
Block => Nblk);
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 Get_If_Case_Generate_Child
(Ctxt : Rti_Context; Gen : Ghdl_Rti_Access) return Rti_Context
is
pragma Assert (Gen.Kind = Ghdl_Rtik_If_Generate
or Gen.Kind = Ghdl_Rtik_Case_Generate);
Blk : constant Ghdl_Rtin_Block_Acc := To_Ghdl_Rtin_Block_Acc (Gen);
Base_Addr : constant Address := Ctxt.Base + Blk.Loc;
-- Address of the block_id field. It is just after the instance field.
-- Assume alignment is ok (it is on 32 and 64 bit platforms).
Id_Addr : constant Address :=
Base_Addr + Ghdl_Index_Type'(Address'Size / Storage_Unit);
Id : Ghdl_Index_Type;
pragma Import (Ada, Id);
for Id'Address use Id_Addr;
begin
return (Base => To_Addr_Acc (Base_Addr).all,
Block => Blk.Children (Id));
end Get_If_Case_Generate_Child;
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 (Gen : Ghdl_Rtin_Generate_Acc;
Ctxt : Rti_Context)
return Ghdl_Index_Type
is
Bod : constant Ghdl_Rtin_Block_Acc :=
To_Ghdl_Rtin_Block_Acc (Gen.Child);
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 (Bod.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
-- Address of the field containing the address of the instance.
Inst_Addr : constant Address := Ctxt.Base + Inst.Loc;
-- Read sub instance address.
Inst_Base : constant Address := To_Addr_Acc (Inst_Addr).all;
begin
-- Read instance RTI.
if Inst_Base = Null_Address then
-- No instance.
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 Extract_Range (Bounds : in out Address;
Def : Ghdl_Rti_Access;
Rng : out Ghdl_Range_Ptr)
is
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;
begin
if Bounds = Null_Address then
-- Propagate failure.
Rng := null;
return;
end if;
case Def.Kind is
when Ghdl_Rtik_Type_I32 =>
Align (Ghdl_Range_I32'Alignment);
Rng := To_Ghdl_Range_Ptr (Bounds);
Update (Ghdl_Range_I32'Size);
when Ghdl_Rtik_Type_B1 =>
Align (Ghdl_Range_B1'Alignment);
Rng := To_Ghdl_Range_Ptr (Bounds);
Update (Ghdl_Range_B1'Size);
when Ghdl_Rtik_Type_E8 =>
Align (Ghdl_Range_E8'Alignment);
Rng := To_Ghdl_Range_Ptr (Bounds);
Update (Ghdl_Range_E8'Size);
when others =>
-- Bounds are not known anymore.
Rng := null;
end case;
end Extract_Range;
function Array_Layout_To_Bounds (Layout : Address) return Address is
begin
return Layout + Ghdl_Index_Type'(Ghdl_Indexes_Type'Size / 8);
end Array_Layout_To_Bounds;
function Array_Layout_To_Element
(Layout : Address; El_Rti : Ghdl_Rti_Access) return Address is
begin
case El_Rti.Kind is
when Ghdl_Rtik_Type_Array
| Ghdl_Rtik_Subtype_Array
| Ghdl_Rtik_Subtype_Unbounded_Array =>
-- Trim size to pass the bounds
return Array_Layout_To_Bounds (Layout);
when Ghdl_Rtik_Type_Unbounded_Record
| Ghdl_Rtik_Subtype_Unbounded_Record =>
-- Keep full layout.
return Layout;
when Ghdl_Rtik_Type_Record =>
return Null_Address;
when others =>
return Null_Address;
end case;
end Array_Layout_To_Element;
procedure Bound_To_Range (Bounds_Addr : Address;
Def : Ghdl_Rtin_Type_Array_Acc;
Res : out Ghdl_Range_Array)
is
Bounds : Address;
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);
Idx_Def := Get_Base_Type (Idx_Def);
Extract_Range (Bounds, Idx_Def, Res (I));
end loop;
end Bound_To_Range;
function Get_Base_Type (Atype : Ghdl_Rti_Access) return Ghdl_Rti_Access
is
Res : Ghdl_Rti_Access;
begin
Res := Atype;
loop
case Res.Kind is
when Ghdl_Rtik_Type_E8
| Ghdl_Rtik_Type_E32
| Ghdl_Rtik_Type_B1
| Ghdl_Rtik_Type_I32
| Ghdl_Rtik_Type_I64
| Ghdl_Rtik_Type_P32
| Ghdl_Rtik_Type_P64
| Ghdl_Rtik_Type_F64 =>
return Res;
when Ghdl_Rtik_Subtype_Scalar =>
Res := To_Ghdl_Rtin_Subtype_Scalar_Acc (Res).Basetype;
when Ghdl_Rtik_Type_Array
| Ghdl_Rtik_Type_Record
| Ghdl_Rtik_Type_Unbounded_Record =>
return Res;
when Ghdl_Rtik_Subtype_Array
| Ghdl_Rtik_Subtype_Unbounded_Array
| Ghdl_Rtik_Subtype_Record
| Ghdl_Rtik_Subtype_Unbounded_Record =>
Res := To_Ghdl_Rtin_Subtype_Composite_Acc (Res).Basetype;
when others =>
Internal_Error ("rtis_addr.get_base_type");
end case;
end loop;
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;