-- GHDL Run Time (GRT) - VHPI implementation.
-- Copyright (C) 2021 Marlon James
--
-- 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>.
with Ada.Unchecked_Conversion;
with Grt.Vhdl_Types; use Grt.Vhdl_Types;
with Grt.Astdio; use Grt.Astdio;
with Grt.Astdio.Vhdl; use Grt.Astdio.Vhdl;
with Grt.Errors; use Grt.Errors;
with Grt.Hooks; use Grt.Hooks;
with Grt.Stdio; use Grt.Stdio;
with Grt.Vstrings; use Grt.Vstrings;
package body Grt.Vhpi is
-- The VHPI interface requires libdl (dlopen, dlsym) to be linked in.
-- This is now set in Makefile, since this is target dependent.
-- pragma Linker_Options ("-ldl");
-- If true, emit traces
Flag_Trace : Boolean := False;
Trace_File : FILEs;
VhpiUndefined_External : constant Integer := -1;
----------------------------------------------------------------------------
-- Internal helper functions
----------------------------------------------------------------------------
function To_Address is new Ada.Unchecked_Conversion
(Vhpi_External_Handle, System.Address);
-- VHPI errors
Default_Message : constant String := "(no error message)" & NUL;
Err_Severity : VhpiSeverityT := VhpiNote;
Err_Message : Ghdl_C_String := To_Ghdl_C_String (Default_Message'Address);
Err_Str : Ghdl_C_String := null;
Err_File : Ghdl_C_String := null;
Err_Line : Integer_32 := -1;
Err_Occured : Boolean := False;
Buf_Err_Message : Vstring;
procedure Reset_Error is
begin
Err_Severity := VhpiNote;
Err_Message := To_Ghdl_C_String (Default_Message'Address);
Err_Str := null;
Err_File := null;
Err_Line := -1;
Err_Occured := False;
end Reset_Error;
Err_Str_S : constant String := "GHDL Error ";
-- VHPI function not implemented
VHPI_0001_Str : constant String := Err_Str_S & "VHPI_0001";
procedure Set_Err_Str (S : String) is
begin
Err_Str := To_Ghdl_C_String (S'Address);
end Set_Err_Str;
procedure Error_Unimplimented (Name : String) is
begin
Err_Severity := VhpiError;
Reset (Buf_Err_Message);
Append (Buf_Err_Message, Name);
Append (Buf_Err_Message, " not implemented");
Append (Buf_Err_Message, NUL);
Err_Message := Get_C_String (Buf_Err_Message);
Set_Err_Str (VHPI_0001_Str);
Err_Occured := True;
end Error_Unimplimented;
-- VHPI tracing
procedure Trace_Start (Msg : String) is
begin
-- TODO: Add indent when callbacks are supported
Put (Trace_File, Msg);
end Trace_Start;
procedure Trace_Newline is
begin
New_Line (Trace_File);
end Trace_Newline;
procedure Trace (Msg : String) is
begin
Put (Trace_File, Msg);
end Trace;
procedure Trace (Str : Ghdl_C_String) is
begin
if Str = null then
Put (Trace_File, "null");
else
Put (Trace_File, '"');
Put (Trace_File, Str);
Put (Trace_File, '"');
end if;
end Trace;
procedure Trace (V : Integer_32) is
begin
Put_I32 (Trace_File, Ghdl_I32 (V));
end Trace;
procedure Trace (V : Integer) is
begin
Put_I32 (Trace_File, Ghdl_I32 (V));
end Trace;
procedure Trace (V : Unsigned_64) is
begin
Put_U64 (Trace_File, Ghdl_U64 (V));
end Trace;
procedure Trace (A : System.Address)
is
begin
Put (Trace_File, A);
end Trace;
procedure Trace (H : Vhpi_External_Handle)
is
begin
Put (Trace_File, To_Address (H));
end Trace;
procedure Trace_Time (V : Std_Time) is
begin
Put_Time (Trace_File, V);
end Trace_Time;
function Vhpi_Time_To_Time (V : VhpiTimeT) return Std_Time is
Res : Std_Time;
begin
Res := Std_Time (Integer_64 (V.High) * 2 ** 32 + Integer_64 (V.Low));
return Res;
end Vhpi_Time_To_Time;
----------------------------------------------------------------------------
-- VHPI functions
----------------------------------------------------------------------------
-- Internal implementations for variadic functions in grt-cvhpi.c
function Vhpi_Assert_Internal (Severity: Integer; Msg : Ghdl_C_String)
return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_assert (");
Trace (Severity);
Trace (", ");
Trace (Msg);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_assert");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end Vhpi_Assert_Internal;
function Vhpi_Control_Internal (CommandInt : Integer; Status : Integer)
return Integer
is
procedure Trace (C : VhpiSimControlT) is
begin
case C is
when VhpiStop =>
Trace ("vhpiStop");
when VhpiFinish =>
Trace ("vhpiFinish");
when VhpiReset =>
Trace ("vhpiReset");
end case;
end Trace;
procedure Get_Command
(C : Integer; Res : out VhpiSimControlT; Error : out AvhpiErrorT)
is
Ef : constant Integer := VhpiSimControlT'Pos (VhpiSimControlT'First);
El : constant Integer := VhpiSimControlT'Pos (VhpiSimControlT'Last);
begin
Error := AvhpiErrorOk;
if C not in Ef .. El then
Error := AvhpiErrorBadEnumVal;
Res := VhpiSimControlT'First;
return;
end if;
Res := VhpiSimControlT'Val(C);
end Get_Command;
Command : VhpiSimControlT;
Err : AvhpiErrorT;
begin
Get_Command (CommandInt, Command, Err);
if Flag_Trace then
Trace_Start ("vhpi_control (");
if Err = AvhpiErrorOk then
Trace (Command);
else
Trace (CommandInt);
Trace (" {invalid command}");
end if;
Trace (", ");
Trace (Status);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_control");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end Vhpi_Control_Internal;
----------------------------------------------------------------------------
-- Callback related
-- vhpiHandleT vhpi_register_cb (vhpiCbDataT *cb_data_p, int32_t flags)
function vhpi_register_cb (Data : VhpiCbData_Access; Flags : Callback_Flags)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_register_cb (");
if Data = null then
Trace (System.Null_Address);
else
Trace ("{reason=");
-- TODO: Add callback reason string
Trace (Data.Reason);
if Data.Time /= null then
Trace (", time=");
Trace_Time (Vhpi_Time_To_Time (Data.Time.all));
end if;
Trace ("}");
end if;
Trace (", ");
Trace (Integer_32 (Flags));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_register_cb");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_register_cb;
-- int vhpi_remove_cb (vhpiHandleT cb_obj)
function vhpi_remove_cb (Cb : Vhpi_External_Handle) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_remove_cb (");
Trace (Cb);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_remove_cb");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_remove_cb;
-- int vhpi_disable_cb (vhpiHandleT cb_obj)
function vhpi_disable_cb (Cb : Vhpi_External_Handle) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_disable_cb (");
Trace (Cb);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_disable_cb");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_disable_cb;
-- int vhpi_enable_cb (vhpiHandleT cb_obj)
function vhpi_enable_cb (Cb : Vhpi_External_Handle) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_enable_cb (");
Trace (Cb);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_enable_cb");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_enable_cb;
-- int vhpi_get_cb_info (vhpiHandleT object, vhpiCbDataT *cb_data_p)
function vhpi_get_cb_info
(Obj : Vhpi_External_Handle; Data : VhpiCbData_Access) return Integer
is
function To_Address is
new Ada.Unchecked_Conversion (VhpiCbData_Access, System.Address);
begin
if Flag_Trace then
Trace_Start ("vhpi_get_cb_info (");
Trace (Obj);
Trace (", ");
Trace (To_Address (Data));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_cb_info");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_get_cb_info;
----------------------------------------------------------------------------
-- For obtaining handles
-- vhpiHandleT vhpi_handle_by_name (const char *name, vhpiHandleT scope)
function vhpi_handle_by_name
(Name : Ghdl_C_String; Scope : Vhpi_External_Handle)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_handle_by_name (");
Trace (Name);
Trace (", ");
Trace (Scope);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_handle_by_name");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_handle_by_name;
-- vhpiHandleT vhpi_handle_by_index (vhpiOneToManyT itRel,
-- vhpiHandleT parent, int32_t indx)
function vhpi_handle_by_index
(Rel : Integer; Parent : Vhpi_External_Handle; Index: Integer)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_handle_by_index (");
Trace (Integer_32 (Rel));
Trace (", ");
Trace (Parent);
Trace (", ");
Trace (Integer_32 (Index));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_handle_by_index");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_handle_by_index;
----------------------------------------------------------------------------
-- For traversing relationships
-- vhpiHandleT vhpi_handle (vhpiOneToOneT type, vhpiHandleT referenceHandle)
function vhpi_handle (Rel: Integer; Ref: Vhpi_External_Handle)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_handle (");
Trace (Integer_32 (Rel));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_handle");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_handle;
-- vhpiHandleT vhpi_iterator (vhpiOneToManyT type,
-- vhpiHandleT referenceHandle)
function vhpi_iterator (Rel: Integer; Ref: Vhpi_External_Handle)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_iterator (");
Trace (Integer_32 (Rel));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_iterator");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_iterator;
-- vhpiHandleT vhpi_scan (vhpiHandleT iterator)
function vhpi_scan (Iter : Vhpi_External_Handle)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_scan (");
Trace (Iter);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_scan");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_scan;
----------------------------------------------------------------------------
-- For processing properties
-- vhpiIntT vhpi_get (vhpiIntPropertyT property, vhpiHandleT object)
function vhpi_get (Property: Integer; Ref: Vhpi_External_Handle)
return VhpiIntT is
begin
if Flag_Trace then
Trace_Start ("vhpi_get (");
Trace (Integer_32 (Property));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get");
if Flag_Trace then
Trace (Integer_32 (VhpiUndefined_External));
Trace (" [not implemented]");
Trace_Newline;
end if;
return VhpiIntT (VhpiUndefined_External);
end vhpi_get;
-- const vhpiCharT * vhpi_get_str (vhpiStrPropertyT property,
-- vhpiHandleT object)
function vhpi_get_str (Property : Integer; Ref : Vhpi_External_Handle)
return Ghdl_C_String is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_str (");
Trace (Integer_32 (Property));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_str");
if Flag_Trace then
Trace (Ghdl_C_String'(null));
Trace (" [not implemented]");
Trace_Newline;
end if;
return null;
end vhpi_get_str;
-- vhpiRealT vhpi_get_real (vhpiRealPropertyT property, vhpiHandleT object)
function vhpi_get_real (Property : Integer; Ref : Vhpi_External_Handle)
return Ghdl_Real is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_real (");
Trace (Integer_32 (Property));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_real");
if Flag_Trace then
Trace ("0.0 [not implemented]");
Trace_Newline;
end if;
return 0.0;
end vhpi_get_real;
-- vhpiPhysT vhpi_get_phys (vhpiPhysPropertyT property, vhpiHandleT object)
function vhpi_get_phys (Property : Integer; Ref : Vhpi_External_Handle)
return VhpiPhysT
is
procedure Trace (V : VhpiPhysT) is
begin
Put (Trace_File, "{high = ");
Put_I32 (Trace_File, Ghdl_I32 (V.High));
Put (Trace_File, ", low = ");
Put_I32 (Trace_File, Ghdl_I32 (V.Low));
Put (Trace_File, '}');
end Trace;
Res : constant VhpiPhysT := (0, 0);
begin
if Flag_Trace then
Trace_Start ("vhpi_get_phys (");
Trace (Integer_32 (Property));
Trace (", ");
Trace (Ref);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_phys");
if Flag_Trace then
Trace (Res);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Res;
end vhpi_get_phys;
----------------------------------------------------------------------------
-- For access to protected types
-- int vhpi_protected_call (vhpiHandleT varHdl,
-- vhpiUserFctT userFct,
-- void *userData)
function vhpi_protected_call (Var : Vhpi_External_Handle;
User_Fun : VhpiUserFctT;
User_Data : System.Address)
return Integer
is
function To_Address is new Ada.Unchecked_Conversion
(VhpiUserFctT, System.Address);
begin
if Flag_Trace then
Trace_Start ("vhpi_protected_call (");
Trace (Var);
Trace (", ");
Trace (To_Address (User_Fun));
Trace (", ");
Trace (User_Data);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_protected_call");
if Flag_Trace then
Trace ("-1 [not implemented]");
Trace_Newline;
end if;
return -1;
end vhpi_protected_call;
----------------------------------------------------------------------------
-- For value processing
function To_Address is new Ada.Unchecked_Conversion
(VhpiValue_Access, System.Address);
function To_Address is new Ada.Unchecked_Conversion
(VhpiTime_Access, System.Address);
-- int vhpi_get_value (vhpiHandleT expr, vhpiValueT *value_p)
function vhpi_get_value
(Expr : Vhpi_External_Handle; Value : VhpiValue_Access) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_value (");
Trace (Expr);
Trace (", ");
Trace (To_Address (Value));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_value");
if Flag_Trace then
Trace ("-1 [not implemented]");
Trace_Newline;
end if;
return -1;
end vhpi_get_value;
-- int vhpi_put_value (vhpiHandleT object,
-- vhpiValueT *value_p,
-- vhpiPutValueModeT mode)
function vhpi_put_value (Obj : Vhpi_External_Handle;
Value : VhpiValue_Access;
ModeInt : Integer)
return Integer
is
procedure Trace (M : VhpiPutValueModeT) is
begin
case M is
when VhpiDeposit =>
Trace ("vhpiDeposit");
when VhpiDepositPropagate =>
Trace ("vhpiDepositPropagate");
when VhpiForce =>
Trace ("vhpiForce");
when VhpiForcePropagate =>
Trace ("vhpiForcePropagate");
when VhpiRelease =>
Trace ("vhpiRelease");
when VhpiSizeConstraint =>
Trace ("vhpiSizeConstraint");
end case;
end Trace;
procedure Get_Mode
(M : Integer; Res : out VhpiPutValueModeT; Error : out AvhpiErrorT)
is
Ef : constant Integer :=
VhpiPutValueModeT'Pos (VhpiPutValueModeT'First);
El : constant Integer :=
VhpiPutValueModeT'Pos (VhpiPutValueModeT'Last);
begin
Error := AvhpiErrorOk;
if M not in Ef .. El then
Error := AvhpiErrorBadEnumVal;
Res := VhpiPutValueModeT'First;
return;
end if;
Res := VhpiPutValueModeT'Val(M);
end Get_Mode;
Mode : VhpiPutValueModeT;
Err : AvhpiErrorT;
begin
Get_Mode (ModeInt, Mode, Err);
if Flag_Trace then
Trace_Start ("vhpi_put_value (");
Trace (Obj);
Trace (", ");
-- TODO: Print value
Trace (To_Address (Value));
Trace (", ");
if Err = AvhpiErrorOk then
Trace (Mode);
else
Trace (ModeInt);
Trace (" {invalid mode}");
end if;
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_put_value");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_put_value;
-- int vhpi_schedule_transaction (vhpiHandleT drivHdl,
-- vhpiValueT *value_p,
-- uint32_t numValues,
-- vhpiTimeT *delayp,
-- vhpiDelayModeT delayMode,
-- vhpiTimeT *pulseRejp)
function vhpi_schedule_transaction (Driver : Vhpi_External_Handle;
Value : VhpiValue_Access;
Num_Values : Unsigned_32;
Delay_Value : VhpiTime_Access;
Delay_ModeInt : Integer;
Pulse_Rejection : VhpiTime_Access)
return Integer
is
procedure Trace (V : Unsigned_32) is
begin
Put_U32 (Trace_File, Ghdl_U32 (V));
end Trace;
procedure Trace (M : VhpiDelayModeT) is
begin
case M is
when VhpiInertial =>
Trace ("vhpiInertial");
when VhpiTransport =>
Trace ("vhpiTransport");
end case;
end Trace;
procedure Get_Mode
(M : Integer; Res : out VhpiDelayModeT; Error : out AvhpiErrorT)
is
Ef : constant Integer := VhpiDelayModeT'Pos (VhpiDelayModeT'First);
El : constant Integer := VhpiDelayModeT'Pos (VhpiDelayModeT'Last);
begin
Error := AvhpiErrorOk;
if M not in Ef .. El then
Error := AvhpiErrorBadEnumVal;
Res := VhpiDelayModeT'First;
return;
end if;
Res := VhpiDelayModeT'Val(M);
end Get_Mode;
Delay_Mode : VhpiDelayModeT;
Err : AvhpiErrorT;
begin
Get_Mode (Delay_ModeInt, Delay_Mode, Err);
if Flag_Trace then
Trace_Start ("vhpi_schedule_transaction (");
Trace (Driver);
Trace (", ");
-- TODO: Print value
Trace (To_Address (Value));
Trace (", ");
Trace (Num_Values);
Trace (", ");
if Delay_Value /= null then
Trace ("{");
Trace_Time (Vhpi_Time_To_Time (Delay_Value.all));
Trace ("}");
else
Trace (To_Address (Delay_Value));
end if;
Trace (", ");
if Err = AvhpiErrorOk then
Trace (Delay_Mode);
else
Trace (Delay_ModeInt);
Trace (" {invalid mode}");
end if;
Trace (", ");
if Pulse_Rejection /= null then
Trace ("{");
Trace_Time (Vhpi_Time_To_Time (Pulse_Rejection.all));
Trace ("}");
else
Trace (To_Address (Pulse_Rejection));
end if;
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_schedule_transaction");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_schedule_transaction;
-- int vhpi_format_value (const vhpiValueT *in_value_p,
-- vhpiValueT *out_value_p)
function vhpi_format_value
(In_Val : VhpiValue_Access; Out_Val : VhpiValue_Access) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_format_value (");
-- TODO: Print value
Trace (To_Address (In_Val));
Trace (", ");
-- TODO: Print output format
Trace (To_Address (Out_Val));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_format_value");
if Flag_Trace then
Trace ("-1 [not implemented]");
Trace_Newline;
end if;
return -1;
end vhpi_format_value;
----------------------------------------------------------------------------
-- For time processing
-- void vhpi_get_time (vhpiTimeT *time_p, long *cycles)
procedure vhpi_get_time (Time : VhpiTime_Access; Cycles : Long_Access)
is
function To_Address is new Ada.Unchecked_Conversion
(Long_Access, System.Address);
begin
if Flag_Trace then
Trace_Start ("vhpi_get_time (");
Trace (To_Address (Time));
Trace (", ");
Trace (To_Address (Cycles));
Trace (") ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_time");
if Flag_Trace then
Trace ("[not implemented]");
Trace_Newline;
end if;
end vhpi_get_time;
-- int vhpi_get_next_time (vhpiTimeT *time_p)
function vhpi_get_next_time (Time : VhpiTime_Access) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_next_time (");
Trace (To_Address (Time));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_next_time");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_get_next_time;
----------------------------------------------------------------------------
-- Utilities to print VHDL strings
-- int vhpi_is_printable ( char ch )
function vhpi_is_printable (Ch : Character) return Integer
is
procedure Trace (C : Character) is
begin
Put (Trace_File, C);
end Trace;
begin
if Flag_Trace then
Trace_Start ("vhpi_is_printable (");
Trace (Ch);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_is_printable");
if Flag_Trace then
Trace ("0 [not implemented]");
Trace_Newline;
end if;
return 0;
end vhpi_is_printable;
----------------------------------------------------------------------------
-- Utility routines
-- int vhpi_compare_handles (vhpiHandleT handle1, vhpiHandleT handle2)
function vhpi_compare_handles (Hdl1, Hdl2 : Vhpi_External_Handle)
return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_compare_handles (");
Trace (Hdl1);
Trace (", ");
Trace (Hdl2);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_compare_handles");
if Flag_Trace then
Trace ("0 [not implemented]");
Trace_Newline;
end if;
return 0;
end vhpi_compare_handles;
-- int vhpi_check_error (vhpiErrorInfoT *error_info_p)
function vhpi_check_error (Info : VhpiErrorInfo_Access) return Integer
is
function To_Address is new Ada.Unchecked_Conversion
(VhpiErrorInfo_Access, System.Address);
function To_Integer (B : Boolean) return Integer is
begin
if B then
return 1;
else
return 0;
end if;
end To_Integer;
Res : Integer;
begin
if Flag_Trace then
Trace_Start ("vhpi_check_error (");
Trace (To_Address (Info));
Trace (") return ");
end if;
if Info /= null then
Info.all := (Severity => Err_Severity,
Msg => Err_Message,
Str => Err_Str,
File => Err_File,
Line => Err_Line);
end if;
Res := To_Integer (Err_Occured);
if Flag_Trace then
Trace (Res);
Trace_Newline;
end if;
return Res;
end vhpi_check_error;
-- int vhpi_release_handle (vhpiHandleT object)
function vhpi_release_handle (Obj : Vhpi_External_Handle) return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_release_handle (");
Trace (To_Address (Obj));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_release_handle");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_release_handle;
----------------------------------------------------------------------------
-- Creation functions
-- vhpiHandleT vhpi_create (vhpiClassKindT kind,
-- vhpiHandleT handle1,
-- vhpiHandleT handle2)
function vhpi_create (Kind : Integer; Hdl1, Hdl2 : Vhpi_External_Handle)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_create (");
Trace (Kind);
Trace (", ");
Trace (Hdl1);
Trace (", ");
Trace (Hdl2);
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_create");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_create;
----------------------------------------------------------------------------
-- Foreign model data structures and functions
function To_Address is new Ada.Unchecked_Conversion
(VhpiForeignData_Access, System.Address);
-- vhpiHandleT vhpi_register_foreignf (vhpiForeignDataT *foreignDatap)
function vhpi_register_foreignf (Data : VhpiForeignData_Access)
return Vhpi_External_Handle is
begin
if Flag_Trace then
Trace_Start ("vhpi_register_foreignf (");
-- TODO: Print foreign model info
Trace (To_Address (Data));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_register_foreignf");
if Flag_Trace then
Trace (Null_External_Handle);
Trace (" [not implemented]");
Trace_Newline;
end if;
return Null_External_Handle;
end vhpi_register_foreignf;
-- int vhpi_get_foreignf_info (vhpiHandleT hdl,
-- vhpiForeignDataT *foreignDatap)
function vhpi_get_foreignf_info
(Hdl : Vhpi_External_Handle; Data : VhpiForeignData_Access)
return Integer is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_foreignf_info (");
Trace (Hdl);
Trace (", ");
Trace (To_Address (Data));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_foreignf_info");
if Flag_Trace then
Trace ("1 [not implemented]");
Trace_Newline;
end if;
return 1;
end vhpi_get_foreignf_info;
----------------------------------------------------------------------------
-- For saving and restoring foreign models data
-- size_t vhpi_get_data (int32_t id, void *dataLoc, size_t numBytes);
function vhpi_get_data
(Id : Integer_32; Data_Loc : System.Address; Num_Bytes : size_t)
return size_t is
begin
if Flag_Trace then
Trace_Start ("vhpi_get_data (");
Trace (Id);
Trace (", ");
Trace (Data_Loc);
Trace (", ");
Trace (Unsigned_64 (Num_Bytes));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_get_data");
if Flag_Trace then
Trace ("0 [not implemented]");
Trace_Newline;
end if;
return 0;
end vhpi_get_data;
-- size_t vhpi_put_data (int32_t id, void *dataLoc, size_t numBytes);
function vhpi_put_data
(Id : Integer_32; Data_Loc : System.Address; Num_Bytes : size_t)
return size_t is
begin
if Flag_Trace then
Trace_Start ("vhpi_put_data (");
Trace (Id);
Trace (", ");
Trace (Data_Loc);
Trace (", ");
Trace (Unsigned_64 (Num_Bytes));
Trace (") return ");
end if;
Reset_Error;
Error_Unimplimented ("vhpi_put_data");
if Flag_Trace then
Trace ("0 [not implemented]");
Trace_Newline;
end if;
return 0;
end vhpi_put_data;
----------------------------------------------------------------------------
-- GHDL hooks
----------------------------------------------------------------------------
type Lib_Cell;
type Lib_Access is access Lib_Cell;
type Lib_Cell is record
File_Name : String_Access;
Func_Name : String_Access;
Next : Lib_Access;
end record;
Vhpi_Libraries : Lib_Access := null;
procedure Vhpi_Help is
begin
Put_Line
(" --vhpi=FILENAME[:ENTRYPOINT] load VHPI library, optionally");
Put_Line
(" provide entry point name");
Put_Line
(" --vhpi-trace[=FILE] trace vhpi calls to stdout or provided FILE");
end Vhpi_Help;
------------------------------------------------------------------------
-- Return TRUE if OPT is an option for VHPI.
function Vhpi_Option (Opt : String) return Boolean
is
F : constant Natural := Opt'First;
procedure Bad_Option is
begin
Error_S ("incorrect option '");
Diag_C (Opt);
Error_E ("'");
end Bad_Option;
begin
if Opt'Length < 6 or else Opt (F .. F + 5) /= "--vhpi" then
return False;
end if;
if Opt'Length = 7 then
Bad_Option;
return False;
end if;
if Opt'Length > 7 and then Opt (F + 6) = '=' then
-- Need to support Windows path names and optional entrypoint.
-- Valid examples:
-- C:\vhpi_lib.dll:entry_func
-- .\vhpi_lib.dll:entry_func
-- ./vhpi_lib.so:entry_func
-- /path/to/vhpi_lib:entry_func
-- vhpi_lib:entry_func
declare
P : Natural;
Lf, Ll, L_Len : Natural;
Ef, El, E_Len : Natural;
Lib : Lib_Access;
File : String_Access;
Func : String_Access;
begin
P := F + 7;
-- Extract library.
Lf := P;
while P <= Opt'Length and then Opt (P) /= ':' loop
P := P + 1;
end loop;
-- Skip colon after volume/drive letter on Windows.
-- This will break if library path is one character.
if P <= Opt'Length and then Opt (P) = ':' and then P = 2 then
while P <= Opt'Length and then Opt (P) /= ':' loop
P := P + 1;
end loop;
end if;
Ll := P - 1;
-- Extract entrypoint.
Ef := P + 1;
El := Opt'Length;
-- Store library info.
Lib := new Lib_Cell;
-- Add an extra NUL character.
L_Len := Ll - Lf + 2;
File := new String (1 .. L_Len);
File (1 .. L_Len - 1) := Opt (Lf .. Ll);
File (File'Last) := NUL;
Lib.File_Name := File;
if Ef <= El then
-- Add an extra NUL character.
E_Len := El - Ef + 2;
Func := new String (1 .. E_Len);
Func (1 .. E_Len - 1) := Opt (Ef .. El);
Func (Func'Last) := NUL;
Lib.Func_Name := Func;
end if;
-- Add new library to the list.
if Vhpi_Libraries = null then
Vhpi_Libraries := Lib;
else
declare
L : Lib_Access := Vhpi_Libraries;
begin
while L.Next /= null loop
L := L.Next;
end loop;
L.Next := Lib;
end;
end if;
end;
return True;
elsif Opt'Length >= 12 and then Opt (F + 6 .. F + 11) = "-trace" then
if Opt'Length > 12 and then Opt (F + 12) = '=' then
declare
Filename : String (1 .. Opt'Length - 12);
Mode : constant String := "wt" & NUL;
begin
Filename (1 .. Filename'Last - 1) := Opt (F + 13 .. Opt'Last);
Filename (Filename'Last) := NUL;
Trace_File := fopen (Filename'Address, Mode'Address);
if Trace_File = NULL_Stream then
Error_S ("cannot open vhpi trace file '");
Diag_C (Opt (F + 13 .. Opt'Last));
Error_E ("'");
return False;
end if;
end;
elsif Opt'Length = 12 then
Trace_File := stdout;
else
Bad_Option;
return False;
end if;
Flag_Trace := True;
return True;
else
return False;
end if;
end Vhpi_Option;
------------------------------------------------------------------------
-- Called before elaboration.
-- int loadVhpiModule (const char* libname, const char* entrypoint)
function LoadVhpiModule (Filename, Funcname: Address) return Integer;
pragma Import (C, LoadVhpiModule, "loadVhpiModule");
procedure Vhpi_Init
is
Lib : Lib_Access := Vhpi_Libraries;
Res : Integer;
begin
if Lib = null then
return;
end if;
while Lib /= null loop
if Lib.Func_Name = null then
Res := LoadVhpiModule
(Lib.File_Name.all'Address, Null_Address);
else
Res := LoadVhpiModule
(Lib.File_Name.all'Address, Lib.Func_Name.all'Address);
end if;
if Res /= 0 then
Error_S ("cannot load VHPI module '");
Diag_C (Lib.File_Name.all);
if Lib.Func_Name /= null then
Diag_C ("' with entry point '");
Diag_C (Lib.Func_Name.all);
end if;
Error_E ("'");
end if;
Lib := Lib.Next;
end loop;
end Vhpi_Init;
------------------------------------------------------------------------
-- Called after elaboration.
procedure Vhpi_Start is
begin
if Vhpi_Libraries = null then
return;
end if;
-- Grt.Rtis_Types.Search_Types_RTI;
-- Execute_Callback_List (VhpiCbStartOfSimulation_List);
end Vhpi_Start;
------------------------------------------------------------------------
-- Called at the end of the simulation.
procedure Vhpi_End is
begin
-- Execute_Callback_List (VhpiCbEndOfSimulation_List);
Free (Buf_Err_Message);
null;
end Vhpi_End;
Vhpi_Hooks : aliased constant Hooks_Type :=
(Desc => new String'("vhpi: vhpi compatible API"),
Option => Vhpi_Option'Access,
Help => Vhpi_Help'Access,
Init => Vhpi_Init'Access,
Start => Vhpi_Start'Access,
Finish => Vhpi_End'Access);
procedure Register is
begin
Register_Hooks (Vhpi_Hooks'Access);
end Register;
end Grt.Vhpi;