-- GHDL Run Time (GRT) - Override top entity generics
-- Copyright (C) 2015 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 System;
with Grt.Types; use Grt.Types;
with Grt.Lib; use Grt.Lib;
with Grt.Options; use Grt.Options;
with Grt.Avhpi; use Grt.Avhpi;
with Grt.Avhpi_Utils; use Grt.Avhpi_Utils;
with Grt.Errors; use Grt.Errors;
with Grt.Rtis; use Grt.Rtis;
with Grt.Rtis_Addr; use Grt.Rtis_Addr;
with Grt.Values;
package body Grt.Change_Generics is
procedure Error_Override (Msg : String; Over : Generic_Override_Acc) is
begin
Error_C (Msg);
Error_C (" '");
Error_C (Over.Name.all);
Error_E ("'");
end Error_Override;
procedure Error_Range (Over : Generic_Override_Acc) is
begin
Error_Override ("value not in range for generic", Over);
end Error_Range;
-- Convert C to E8 values
procedure Ghdl_Value_E8_Char (Res : out Ghdl_E8;
Err : out Boolean;
C : Character;
Rti : Ghdl_Rti_Access)
is
Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc :=
To_Ghdl_Rtin_Type_Enum_Acc (Rti);
Lit_Name : Ghdl_C_String;
begin
for I in 0 .. Enum_Rti.Nbr - 1 loop
Lit_Name := Enum_Rti.Names (I);
if Lit_Name (1) = ''' and Lit_Name (2) = C and Lit_Name (3) = ''' then
Res := Ghdl_E8 (I);
Err := False;
return;
end if;
end loop;
Res := 0;
Err := True;
end Ghdl_Value_E8_Char;
-- Override for unconstrained array generic.
procedure Override_Generic_Array (Obj_Rti : Ghdl_Rtin_Object_Acc;
Ctxt : Rti_Context;
Over : Generic_Override_Acc)
is
Type_Rti : constant Ghdl_Rtin_Type_Array_Acc :=
To_Ghdl_Rtin_Type_Array_Acc (Obj_Rti.Obj_Type);
El_Rti : constant Ghdl_Rti_Access := Type_Rti.Element;
Idx_Rti : constant Ghdl_Rti_Access := Type_Rti.Indexes (0);
Idx_Base_Rti : Ghdl_Rti_Access;
St_Rng, Rng : Ghdl_Range_Ptr;
Arr : Ghdl_E8_Array_Base_Ptr;
Err : Boolean;
Len : Ghdl_Index_Type;
Uc_Array : Ghdl_Uc_Array_Acc;
begin
-- Check array type:
-- - Must be one dimension
if Type_Rti.Nbr_Dim /= 1 then
Error_Override ("multi-dimension array not supported for "
& "override of generic", Over);
return;
end if;
-- - Index must be a scalar integer
if Idx_Rti.Kind /= Ghdl_Rtik_Subtype_Scalar then
Internal_Error ("override_generic_array");
end if;
Idx_Base_Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Idx_Rti).Basetype;
if Idx_Base_Rti.Kind /= Ghdl_Rtik_Type_I32 then
Error_Override ("non Integer array index not supported for "
& "override of generic", Over);
return;
end if;
-- - Element must be E8 enum.
if El_Rti.Kind /= Ghdl_Rtik_Type_E8 then
Error_Override ("non enumerated element type not supported for "
& "override of generic", Over);
return;
end if;
-- The real work can start.
St_Rng := To_Ghdl_Range_Ptr
(Loc_To_Addr (Idx_Rti.Depth,
To_Ghdl_Rtin_Subtype_Scalar_Acc (Idx_Rti).Range_Loc,
Ctxt));
-- Create the value.
Len := Over.Value'Length;
Arr := To_Ghdl_E8_Array_Base_Ptr (Ghdl_Malloc (Len));
for I in Over.Value'range loop
Ghdl_Value_E8_Char (Arr (Ghdl_Index_Type (I - Over.Value'First)), Err,
Over.Value (I), El_Rti);
if Err then
Error_Override ("invalid character for override of generic", Over);
return;
end if;
end loop;
-- Create the range.
Rng := new Ghdl_Range_Type (Mode_I32);
Rng.I32.Left := St_Rng.I32.Left;
Rng.I32.Dir := St_Rng.I32.Dir;
case Rng.I32.Dir is
when Dir_To =>
Rng.I32.Right := Rng.I32.Left + Ghdl_I32 (Len - 1);
when Dir_Downto =>
Rng.I32.Right := Rng.I32.Left - Ghdl_I32 (Len - 1);
end case;
Rng.I32.Len := Len;
-- Override the generic. Don't try to free previous value as it may
-- not have been dynamically allocated.
Uc_Array := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt));
Uc_Array.all := (Base => Arr (0)'Address,
Bounds => Rng.all'Address);
end Override_Generic_Array;
procedure Override_Generic_I32 (Obj_Rti : Ghdl_Rtin_Object_Acc;
Ctxt : Rti_Context;
Over : Generic_Override_Acc)
is
Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj_Rti.Obj_Type);
Rng : Ghdl_Range_Ptr;
Res : Ghdl_I64;
Ptr : Ghdl_Value_Ptr;
begin
Res := Grt.Values.Value_I64
(To_Std_String_Basep (Over.Value.all'Address), Over.Value'Length, 0);
-- Check range.
Rng := To_Ghdl_Range_Ptr
(Loc_To_Addr (Subtype_Rti.Common.Depth, Subtype_Rti.Range_Loc, Ctxt));
case Rng.I32.Dir is
when Dir_To =>
if Res < Ghdl_I64 (Rng.I32.Left)
or else Res > Ghdl_I64 (Rng.I32.Right)
then
Error_Range (Over);
end if;
when Dir_Downto =>
if Res > Ghdl_I64 (Rng.I32.Left)
or else Res < Ghdl_I64 (Rng.I32.Right)
then
Error_Range (Over);
end if;
end case;
-- Assign.
Ptr := To_Ghdl_Value_Ptr
(Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt));
Ptr.I32 := Ghdl_I32 (Res);
end Override_Generic_I32;
procedure Override_Generic_Enum (Obj_Rti : Ghdl_Rtin_Object_Acc;
Ctxt : Rti_Context;
Over : Generic_Override_Acc;
Type_Rti : Ghdl_Rti_Access)
is
Res : Ghdl_Index_Type;
Ptr : Ghdl_Value_Ptr;
begin
Res := Grt.Values.Value_Enum
(To_Std_String_Basep (Over.Value.all'Address),
Over.Value'Length, Type_Rti);
-- Assign.
Ptr := To_Ghdl_Value_Ptr
(Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt));
case Obj_Rti.Obj_Type.Kind is
when Ghdl_Rtik_Type_E8 =>
Ptr.E8 := Ghdl_E8 (Res);
when Ghdl_Rtik_Type_B1 =>
Ptr.B1 := Ghdl_B1'Val (Res);
when Ghdl_Rtik_Subtype_Scalar =>
declare
Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
To_Ghdl_Rtin_Subtype_Scalar_Acc (Obj_Rti.Obj_Type);
Rng : Ghdl_Range_Ptr;
begin
Rng := To_Ghdl_Range_Ptr
(Loc_To_Addr (Subtype_Rti.Common.Depth,
Subtype_Rti.Range_Loc, Ctxt));
case Subtype_Rti.Basetype.Kind is
when Ghdl_Rtik_Type_E8 =>
case Rng.E8.Dir is
when Dir_To =>
if Res < Ghdl_Index_Type (Rng.E8.Left)
or else Res > Ghdl_Index_Type (Rng.E8.Right)
then
Error_Range (Over);
end if;
when Dir_Downto =>
if Res > Ghdl_Index_Type (Rng.E8.Left)
or else Res < Ghdl_Index_Type (Rng.E8.Right)
then
Error_Range (Over);
end if;
end case;
Ptr.E8 := Ghdl_E8 (Res);
when others =>
Internal_Error ("override_generic_enum");
end case;
end;
when others =>
Internal_Error ("override_generic_enum");
end case;
end Override_Generic_Enum;
-- Override DECL with OVER. Dispatch according to generic type.
procedure Override_Generic_Value (Decl : VhpiHandleT;
Over : Generic_Override_Acc)
is
Rti : constant Ghdl_Rti_Access := Avhpi_Get_Rti (Decl);
Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
To_Ghdl_Rtin_Object_Acc (Rti);
Type_Rti : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type;
Ctxt : constant Rti_Context := Avhpi_Get_Context (Decl);
begin
pragma Assert (Rti.Kind = Ghdl_Rtik_Generic);
case Type_Rti.Kind is
when Ghdl_Rtik_Type_Array =>
Override_Generic_Array (Obj_Rti, Ctxt, Over);
when Ghdl_Rtik_Type_B1
| Ghdl_Rtik_Type_E8 =>
Override_Generic_Enum (Obj_Rti, Ctxt, Over, Type_Rti);
when Ghdl_Rtik_Subtype_Scalar =>
declare
Subtype_Rti : constant Ghdl_Rtin_Subtype_Scalar_Acc :=
To_Ghdl_Rtin_Subtype_Scalar_Acc (Type_Rti);
begin
case Subtype_Rti.Basetype.Kind is
when Ghdl_Rtik_Type_I32 =>
Override_Generic_I32 (Obj_Rti, Ctxt, Over);
when Ghdl_Rtik_Type_E8 =>
Override_Generic_Enum
(Obj_Rti, Ctxt, Over, Subtype_Rti.Basetype);
when others =>
Error_Override
("unhandled type for generic override of", Over);
end case;
end;
when others =>
Error_Override ("unhandled type for generic override of", Over);
end case;
end Override_Generic_Value;
-- Handle generic override OVER. Find the generic declaration.
procedure Override_Generic (Over : Generic_Override_Acc)
is
Root, It, Decl : VhpiHandleT;
Error : AvhpiErrorT;
begin
Get_Root_Inst (Root);
-- Find generic.
Vhpi_Iterator (VhpiDecls, Root, It, Error);
if Error /= AvhpiErrorOk then
Internal_Error ("override_generic(1)");
return;
end if;
-- Look for the generic.
loop
Vhpi_Scan (It, Decl, Error);
exit when Error = AvhpiErrorIteratorEnd;
if Error /= AvhpiErrorOk then
Internal_Error ("override_generic(2)");
return;
end if;
exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK;
if Name_Compare (Decl, Over.Name.all) then
Override_Generic_Value (Decl, Over);
return;
end if;
end loop;
Error_Override ("cannot find in top entity generic", Over);
end Override_Generic;
procedure Change_All_Generics
is
Over : Generic_Override_Acc;
begin
-- Handle overrides one by one (in order).
Over := First_Generic_Override;
while Over /= null loop
Override_Generic (Over);
Over := Over.Next;
end loop;
end Change_All_Generics;
procedure Check_Required_Generic_Override
is
Root, It, Decl : VhpiHandleT;
Error : AvhpiErrorT;
begin
Get_Root_Inst (Root);
-- Find generic.
Vhpi_Iterator (VhpiDecls, Root, It, Error);
if Error /= AvhpiErrorOk then
Internal_Error ("override_generic(1)");
return;
end if;
-- Look for the generic.
loop
Vhpi_Scan (It, Decl, Error);
exit when Error = AvhpiErrorIteratorEnd;
if Error /= AvhpiErrorOk then
Internal_Error ("override_generic(2)");
return;
end if;
exit when Vhpi_Get_Kind (Decl) /= VhpiGenericDeclK;
declare
use System;
Rti : constant Ghdl_Rti_Access := Avhpi_Get_Rti (Decl);
Obj_Rti : constant Ghdl_Rtin_Object_Acc :=
To_Ghdl_Rtin_Object_Acc (Rti);
Type_Rti : constant Ghdl_Rti_Access := Obj_Rti.Obj_Type;
Ctxt : constant Rti_Context := Avhpi_Get_Context (Decl);
begin
pragma Assert (Rti.Kind = Ghdl_Rtik_Generic);
if Type_Rti.Kind = Ghdl_Rtik_Type_Array then
declare
Uc_Array : Ghdl_Uc_Array_Acc;
begin
Uc_Array := To_Ghdl_Uc_Array_Acc
(Loc_To_Addr (Obj_Rti.Common.Depth, Obj_Rti.Loc, Ctxt));
if Uc_Array.Base = Null_Address then
Error_C ("top-level generic '");
Error_C (Obj_Rti.Name);
Error_E ("' must be overriden (use -gGEN=VAL)");
end if;
end;
end if;
end;
end loop;
end Check_Required_Generic_Override;
end Grt.Change_Generics;