diff options
Diffstat (limited to 'src/grt/grt-vhpi.adb')
| -rw-r--r-- | src/grt/grt-vhpi.adb | 753 |
1 files changed, 753 insertions, 0 deletions
diff --git a/src/grt/grt-vhpi.adb b/src/grt/grt-vhpi.adb new file mode 100644 index 000000000..9f3b9a213 --- /dev/null +++ b/src/grt/grt-vhpi.adb @@ -0,0 +1,753 @@ +-- GHDL Run Time (GRT) - VHPI implementation. +-- Copyright (C) 2021 Marlon James +-- +-- 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 Ada.Unchecked_Conversion; +with Grt.Astdio; use Grt.Astdio; +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; + pragma Unreferenced (Flag_Trace); + + VhpiUndefined_External : constant Integer := -1; + + ---------------------------------------------------------------------------- + -- Internal helper functions + ---------------------------------------------------------------------------- + + -- 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; + + -- Internal implementations for variadic functions in grt-cvhpi.c + + function Vhpi_Assert_Internal (Severity: Integer; Msg : Ghdl_C_String) + return Integer + is + pragma Unreferenced (Severity); + pragma Unreferenced (Msg); + begin + Reset_Error; + Error_Unimplimented ("vhpi_assert"); + return 0; + end Vhpi_Assert_Internal; + + function Vhpi_Control_Internal (Command : VhpiSimControlT; Status : Integer) + return Integer + is + pragma Unreferenced (Command); + pragma Unreferenced (Status); + begin + Reset_Error; + Error_Unimplimented ("vhpi_control"); + return 0; + end Vhpi_Control_Internal; + + ---------------------------------------------------------------------------- + -- VHPI functions + ---------------------------------------------------------------------------- + + ---------------------------------------------------------------------------- + -- 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 + pragma Unreferenced (Data); + pragma Unreferenced (Flags); + begin + Reset_Error; + Error_Unimplimented ("vhpi_register_cb"); + return null; + end vhpi_register_cb; + + -- int vhpi_remove_cb (vhpiHandleT cb_obj) + function vhpi_remove_cb (Cb : Vhpi_External_Handle) return Integer + is + pragma Unreferenced (Cb); + begin + Reset_Error; + Error_Unimplimented ("vhpi_remove_cb"); + return 0; + end vhpi_remove_cb; + + -- int vhpi_disable_cb (vhpiHandleT cb_obj) + function vhpi_disable_cb (Cb : Vhpi_External_Handle) return Integer + is + pragma Unreferenced (Cb); + begin + Reset_Error; + Error_Unimplimented ("vhpi_disable_cb"); + return 0; + end vhpi_disable_cb; + + -- int vhpi_enable_cb (vhpiHandleT cb_obj) + function vhpi_enable_cb (Cb : Vhpi_External_Handle) return Integer + is + pragma Unreferenced (Cb); + begin + Reset_Error; + Error_Unimplimented ("vhpi_enable_cb"); + return 0; + 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 + pragma Unreferenced (Obj); + pragma Unreferenced (Data); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_cb_info"); + return 0; + 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 + pragma Unreferenced (Name); + pragma Unreferenced (Scope); + begin + Reset_Error; + Error_Unimplimented ("vhpi_handle_by_name"); + return null; + 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 + pragma Unreferenced (Rel); + pragma Unreferenced (Parent); + pragma Unreferenced (Index); + begin + Reset_Error; + Error_Unimplimented ("vhpi_handle_by_index"); + return null; + 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 + pragma Unreferenced (Rel); + pragma Unreferenced (Ref); + begin + Reset_Error; + Error_Unimplimented ("vhpi_handle"); + return null; + end vhpi_handle; + + -- vhpiHandleT vhpi_iterator (vhpiOneToManyT type, + -- vhpiHandleT referenceHandle) + function vhpi_iterator (Rel: Integer; Ref: Vhpi_External_Handle) + return Vhpi_External_Handle + is + pragma Unreferenced (Rel); + pragma Unreferenced (Ref); + begin + Reset_Error; + Error_Unimplimented ("vhpi_iterator"); + return null; + end vhpi_iterator; + + -- vhpiHandleT vhpi_scan (vhpiHandleT iterator) + function vhpi_scan (Iter : Vhpi_External_Handle) return Vhpi_External_Handle + is + pragma Unreferenced (Iter); + begin + Reset_Error; + Error_Unimplimented ("vhpi_scan"); + return null; + 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 + pragma Unreferenced (Property); + pragma Unreferenced (Ref); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get"); + 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 + pragma Unreferenced (Property); + pragma Unreferenced (Ref); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_str"); + 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 + pragma Unreferenced (Property); + pragma Unreferenced (Ref); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_real"); + 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 + pragma Unreferenced (Property); + pragma Unreferenced (Ref); + + Res : constant VhpiPhysT := (0, 0); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_phys"); + 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 + pragma Unreferenced (Var); + pragma Unreferenced (User_Fun); + pragma Unreferenced (User_Data); + begin + Reset_Error; + Error_Unimplimented ("vhpi_protected_call"); + return 0; + end vhpi_protected_call; + + -- For value processing + + -- int vhpi_get_value (vhpiHandleT expr, vhpiValueT *value_p) + function vhpi_get_value + (Expr : Vhpi_External_Handle; Value : VhpiValue_Access) return Integer + is + pragma Unreferenced (Expr); + pragma Unreferenced (Value); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_value"); + return 0; + 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; + Mode : VhpiPutValueModeT) + return Integer + is + pragma Unreferenced (Obj); + pragma Unreferenced (Value); + pragma Unreferenced (Mode); + begin + Reset_Error; + Error_Unimplimented ("vhpi_put_value"); + return 0; + 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_Mode : VhpiDelayModeT; + Pulse_Rejection : VhpiTime_Access) + return Integer + is + pragma Unreferenced (Driver); + pragma Unreferenced (Value); + pragma Unreferenced (Num_Values); + pragma Unreferenced (Delay_Value); + pragma Unreferenced (Delay_Mode); + pragma Unreferenced (Pulse_Rejection); + begin + Reset_Error; + Error_Unimplimented ("vhpi_schedule_transaction"); + return 0; + 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 + pragma Unreferenced (In_Val); + pragma Unreferenced (Out_Val); + begin + Reset_Error; + Error_Unimplimented ("vhpi_format_value"); + return 0; + end vhpi_format_value; + + -- For time processing + + -- void vhpi_get_time (vhpiTimeT *time_p, long *cycles) + procedure vhpi_get_time (Time : VhpiTime_Access; Cycles : access Integer) + is + pragma Unreferenced (Time); + pragma Unreferenced (Cycles); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_time"); + null; + end vhpi_get_time; + + -- int vhpi_get_next_time (vhpiTimeT *time_p) + function vhpi_get_next_time (Time : VhpiTime_Access) return Integer + is + pragma Unreferenced (Time); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_next_time"); + return 0; + 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 + pragma Unreferenced (Ch); + begin + Reset_Error; + Error_Unimplimented ("vhpi_is_printable"); + 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 + pragma Unreferenced (Hdl1); + pragma Unreferenced (Hdl2); + begin + Reset_Error; + Error_Unimplimented ("vhpi_compare_handles"); + 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_Integer (B : Boolean) return Integer is + begin + if B then + return 1; + else + return 0; + end if; + end To_Integer; + begin + if Info /= null then + Info.all := (Severity => Err_Severity, + Msg => Err_Message, + Str => Err_Str, + File => Err_File, + Line => Err_Line); + end if; + return To_Integer (Err_Occured); + end vhpi_check_error; + + -- int vhpi_release_handle (vhpiHandleT object) + function vhpi_release_handle (Obj : Vhpi_External_Handle) return Integer + is + pragma Unreferenced (Obj); + begin + Reset_Error; + Error_Unimplimented ("vhpi_release_handle"); + return 0; + 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 + pragma Unreferenced (Kind); + pragma Unreferenced (Hdl1); + pragma Unreferenced (Hdl2); + begin + Reset_Error; + Error_Unimplimented ("vhpi_create"); + return null; + end vhpi_create; + + -- Foreign model data structures and functions + + -- vhpiHandleT vhpi_register_foreignf (vhpiForeignDataT *foreignDatap) + function vhpi_register_foreignf (Data : VhpiForeignData_Access) + return Vhpi_External_Handle + is + pragma Unreferenced (Data); + begin + Reset_Error; + Error_Unimplimented ("vhpi_register_foreignf"); + return null; + 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 + pragma Unreferenced (Hdl); + pragma Unreferenced (Data); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_foreignf_info"); + return 0; + 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 + pragma Unreferenced (Id); + pragma Unreferenced (Data_Loc); + pragma Unreferenced (Num_Bytes); + begin + Reset_Error; + Error_Unimplimented ("vhpi_get_data"); + 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 + pragma Unreferenced (Id); + pragma Unreferenced (Data_Loc); + pragma Unreferenced (Num_Bytes); + begin + Reset_Error; + Error_Unimplimented ("vhpi_put_data"); + 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; |