-- GHDL Run Time (GRT) - VPI interface. -- Copyright (C) 2002 - 2014 Tristan Gingold & Felix Bertram -- -- 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. -- Description: VPI interface for GRT runtime -- the main purpose of this code is to interface with the -- Icarus Verilog Interactive (IVI) simulator GUI ------------------------------------------------------------------------------- -- TODO: ------------------------------------------------------------------------------- -- DONE: -- * The GHDL VPI implementation doesn't support time -- callbacks (cbReadOnlySynch). This is needed to support -- IVI run. Currently, the GHDL simulation runs until -- complete once a single 'run' is performed... -- * You are loading '_'-prefixed symbols when you -- load the vpi plugin. On Linux, there is no leading -- '_'. I just added code to try both '_'-prefixed and -- non-'_'-prefixed symbols. I have placed the changed -- file in the same download dir as the snapshot -- * I did find out why restart doesn't work for GHDL. -- You are passing back the leaf name of signals when the -- FullName is requested. ------------------------------------------------------------------------------- with Ada.Unchecked_Deallocation; with System.Storage_Elements; -- Work around GNAT bug. pragma Unreferenced (System.Storage_Elements); with Grt.Stdio; use Grt.Stdio; with Grt.C; use Grt.C; with Grt.Signals; use Grt.Signals; with Grt.Astdio; use Grt.Astdio; with Grt.Hooks; use Grt.Hooks; with Grt.Options; with Grt.Vcd; use Grt.Vcd; with Grt.Errors; use Grt.Errors; with Grt.Rtis_Types; with Grt.Std_Logic_1164; use Grt.Std_Logic_1164; with Grt.Callbacks; use Grt.Callbacks; package body Grt.Vpi is -- The VPI interface requires libdl (dlopen, dlsym) to be linked in. -- This is now set in Makefile, since this is target dependent. -- pragma Linker_Options ("-ldl"); --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; --errNoString: constant String := "grt-vcd.adb: no string" & NUL; Product : constant String := "GHDL" & NUL; Version : constant String := "0.1" & NUL; -- If true, emit traces Flag_Trace : Boolean := False; ------------------------------------------------------------------------------- -- * * * h e l p e r s * * * * * * * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------- ------------------------------------------------------------------------ -- debugging helpers procedure dbgPut (Str : String) is S : size_t; pragma Unreferenced (S); begin S := fwrite (Str'Address, Str'Length, 1, stderr); end dbgPut; procedure dbgPut (C : Character) is R : int; pragma Unreferenced (R); begin R := fputc (Character'Pos (C), stderr); end dbgPut; procedure dbgNew_Line is begin dbgPut (Nl); end dbgNew_Line; procedure dbgPut_Line (Str : String) is begin dbgPut (Str); dbgNew_Line; end dbgPut_Line; -- procedure dbgPut_Line (Str : Ghdl_Str_Len_Type) -- is -- begin -- Put_Str_Len(stderr, Str); -- dbgNew_Line; -- end dbgPut_Line; procedure Free is new Ada.Unchecked_Deallocation (Name => vpiHandle, Object => struct_vpiHandle); ------------------------------------------------------------------------ -- NUL-terminate strings. -- note: there are several buffers -- see IEEE 1364-2001 -- tmpstring1: string(1..1024); -- function NulTerminate1 (Str : Ghdl_Str_Len_Type) return Ghdl_C_String -- is -- begin -- for i in 1..Str.Len loop -- tmpstring1(i):= Str.Str(i); -- end loop; -- tmpstring1(Str.Len+1):= NUL; -- return To_Ghdl_C_String (tmpstring1'Address); -- end NulTerminate1; -- Clear error status. procedure Reset_Error; procedure Vpi_Trace (Msg : String) is begin if Flag_Trace then Put_Line (Msg); end if; end Vpi_Trace; function Vpi_Time_To_Time (V : s_vpi_time) return Std_Time is Res : Std_Time; begin if V.mType /= vpiSimTime then raise Program_Error; end if; Res := Std_Time (Unsigned_64 (V.mHigh) * 2 ** 32 + Unsigned_64 (V.mLow)); return Res * 1000; end Vpi_Time_To_Time; ------------------------------------------------------------------------------- -- * * * V P I f u n c t i o n s * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------- ------------------------------------------------------------------------ -- vpiHandle vpi_iterate(int type, vpiHandle ref) -- Obtain an iterator handle to objects with a one-to-many relationship. -- see IEEE 1364-2001, page 685 function vpi_iterate (aType: integer; Ref: vpiHandle) return vpiHandle is Res : vpiHandle; Rel : VhpiOneToManyT; Error : AvhpiErrorT; begin Vpi_Trace ("vpi_iterate"); Reset_Error; case aType is when vpiNet => Rel := VhpiDecls; when vpiModule => if Ref = null then Res := new struct_vpiHandle (vpiModule); Get_Root_Inst (Res.Ref); return Res; else Rel := VhpiInternalRegions; end if; when vpiInternalScope => Rel := VhpiInternalRegions; when others => return null; end case; -- find the proper start object for our scan if Ref = null then return null; end if; Res := new struct_vpiHandle (aType); Vhpi_Iterator (Rel, Ref.Ref, Res.Ref, Error); if Error /= AvhpiErrorOk then Free (Res); end if; return Res; end vpi_iterate; ------------------------------------------------------------------------ -- int vpi_get(int property, vpiHandle ref) -- Get the value of an integer or boolean property of an object. -- see IEEE 1364-2001, chapter 27.6, page 667 -- function ii_vpi_get_type (aRef: Ghdl_Instance_Name_Acc) return Integer -- is -- begin -- case aRef.Kind is -- when Ghdl_Name_Entity -- | Ghdl_Name_Architecture -- | Ghdl_Name_Block -- | Ghdl_Name_Generate_Iterative -- | Ghdl_Name_Generate_Conditional -- | Ghdl_Name_Instance => -- return vpiModule; -- when Ghdl_Name_Signal => -- return vpiNet; -- when others => -- return vpiUndefined; -- end case; -- end ii_vpi_get_type; function vpi_get (Property: integer; Ref: vpiHandle) return Integer is begin Vpi_Trace ("vpi_get"); case Property is when vpiType=> return Ref.mType; when vpiTimePrecision=> return -9; -- is this nano-seconds? when others=> dbgPut_Line ("vpi_get: unknown property"); return 0; end case; end vpi_get; function Vhpi_Handle_To_Vpi_Prop (Res : VhpiHandleT) return Integer is begin case Vhpi_Get_Kind (Res) is when VhpiEntityDeclK | VhpiArchBodyK | VhpiBlockStmtK | VhpiIfGenerateK | VhpiForGenerateK | VhpiCompInstStmtK => return vpiModule; when VhpiPortDeclK | VhpiSigDeclK => declare Info : Verilog_Wire_Info; begin Get_Verilog_Wire (Res, Info); if Info.Kind /= Vcd_Bad then return vpiNet; end if; end; when others => null; end case; return vpiUndefined; end Vhpi_Handle_To_Vpi_Prop; function Build_vpiHandle (Res : VhpiHandleT; Prop : Integer) return vpiHandle is begin case Prop is when vpiModule => return new struct_vpiHandle'(mType => vpiModule, Ref => Res); when vpiNet => return new struct_vpiHandle'(mType => vpiNet, Ref => Res); when others => return null; end case; end Build_vpiHandle; ------------------------------------------------------------------------ -- vpiHandle vpi_scan(vpiHandle iter) -- Scan the Verilog HDL hierarchy for objects with a one-to-many -- relationship. -- see IEEE 1364-2001, chapter 27.36, page 709 function vpi_scan (Iter: vpiHandle) return vpiHandle is Res : VhpiHandleT; Error : AvhpiErrorT; R : vpiHandle; Kind, Expected_Kind : Integer; begin Vpi_Trace ("vpi_scan"); if Iter = null then return null; end if; -- There is only one top-level module. if Iter.mType = vpiModule then case Vhpi_Get_Kind (Iter.Ref) is when VhpiRootInstK => R := new struct_vpiHandle (Iter.mType); R.Ref := Iter.Ref; Iter.Ref := Null_Handle; return R; when VhpiUndefined => return null; when others => -- Fall through. null; end case; end if; case Iter.mType is when vpiInternalScope | vpiModule => Expected_Kind := vpiModule; when vpiNet => Expected_Kind := vpiNet; when others => Expected_Kind := vpiUndefined; end case; loop Vhpi_Scan (Iter.Ref, Res, Error); exit when Error /= AvhpiErrorOk; Kind := Vhpi_Handle_To_Vpi_Prop (Res); if Kind /= vpiUndefined and then Kind = Expected_Kind then return Build_vpiHandle (Res, Kind); end if; end loop; return null; end vpi_scan; ------------------------------------------------------------------------ -- char *vpi_get_str(int property, vpiHandle ref) -- see IEEE 1364-2001, page xxx Tmpstring2 : String (1 .. 1024); function vpi_get_str (Property : Integer; Ref : vpiHandle) return Ghdl_C_String is Prop : VhpiStrPropertyT; Len : Natural; begin Vpi_Trace ("vpi_get_str"); if Ref = null then return null; end if; case Property is when vpiFullName=> Prop := VhpiFullNameP; when vpiName=> Prop := VhpiNameP; when others=> dbgPut_Line ("vpi_get_str: undefined property"); return null; end case; Vhpi_Get_Str (Prop, Ref.Ref, Tmpstring2, Len); Tmpstring2 (Len + 1) := NUL; if Property = vpiFullName then for I in Tmpstring2'First .. Len loop if Tmpstring2 (I) = ':' then Tmpstring2 (I) := '.'; end if; end loop; -- Remove the initial '.'. return To_Ghdl_C_String (Tmpstring2 (2)'Address); else return To_Ghdl_C_String (Tmpstring2'Address); end if; end vpi_get_str; ------------------------------------------------------------------------ -- vpiHandle vpi_handle(int type, vpiHandle ref) -- Obtain a handle to an object with a one-to-one relationship. -- see IEEE 1364-2001, chapter 27.16, page 682 function vpi_handle (aType : Integer; Ref : vpiHandle) return vpiHandle is Res : vpiHandle; begin Vpi_Trace ("vpi_handle"); if Ref = null then return null; end if; case aType is when vpiScope => case Ref.mType is when vpiModule => Res := new struct_vpiHandle (vpiScope); Res.Ref := Ref.Ref; return Res; when others => return null; end case; when vpiRightRange | vpiLeftRange => case Ref.mType is when vpiNet => Res := new struct_vpiHandle (aType); Res.Ref := Ref.Ref; return Res; when others => return null; end case; when others => return null; end case; end vpi_handle; ------------------------------------------------------------------------ -- void vpi_get_value(vpiHandle expr, p_vpi_value value); -- Retrieve the simulation value of an object. -- see IEEE 1364-2001, chapter 27.14, page 675 Tmpstring3idx : integer; Tmpstring3 : String (1 .. 1024); procedure ii_vpi_get_value_bin_str_B1 (Val : Ghdl_B1) is begin case Val is when True => Tmpstring3 (Tmpstring3idx) := '1'; when False => Tmpstring3 (Tmpstring3idx) := '0'; end case; Tmpstring3idx := Tmpstring3idx + 1; end ii_vpi_get_value_bin_str_B1; procedure ii_vpi_get_value_bin_str_E8 (Val : Ghdl_E8) is type Map_Type_E8 is array (Ghdl_E8 range 0..8) of character; Map_Std_E8: constant Map_Type_E8 := "UX01ZWLH-"; begin if Val not in Map_Type_E8'range then Tmpstring3 (Tmpstring3idx) := '?'; else Tmpstring3 (Tmpstring3idx) := Map_Std_E8(Val); end if; Tmpstring3idx := Tmpstring3idx + 1; end ii_vpi_get_value_bin_str_E8; function ii_vpi_get_value_bin_str (Obj : VhpiHandleT) return Ghdl_C_String is Info : Verilog_Wire_Info; Len : Ghdl_Index_Type; begin case Vhpi_Get_Kind (Obj) is when VhpiPortDeclK | VhpiSigDeclK => null; when others => return null; end case; -- Get verilog compat info. Get_Verilog_Wire (Obj, Info); if Info.Kind = Vcd_Bad then return null; end if; if Info.Irange = null then Len := 1; else Len := Info.Irange.I32.Len; end if; Tmpstring3idx := 1; -- reset string buffer case Info.Val is when Vcd_Effective => case Info.Kind is when Vcd_Bad | Vcd_Integer32 | Vcd_Float64 => return null; when Vcd_Bit | Vcd_Bool | Vcd_Bitvector => for J in 0 .. Len - 1 loop ii_vpi_get_value_bin_str_B1 (Info.Sigs (J).Value_Ptr.B1); end loop; when Vcd_Stdlogic | Vcd_Stdlogic_Vector => for J in 0 .. Len - 1 loop ii_vpi_get_value_bin_str_E8 (Info.Sigs (J).Value_Ptr.E8); end loop; end case; when Vcd_Driving => case Info.Kind is when Vcd_Bad | Vcd_Integer32 | Vcd_Float64 => return null; when Vcd_Bit | Vcd_Bool | Vcd_Bitvector => for J in 0 .. Len - 1 loop ii_vpi_get_value_bin_str_B1 (Info.Sigs (J).Driving_Value.B1); end loop; when Vcd_Stdlogic | Vcd_Stdlogic_Vector => for J in 0 .. Len - 1 loop ii_vpi_get_value_bin_str_E8 (Info.Sigs (J).Driving_Value.E8); end loop; end case; end case; Tmpstring3 (Tmpstring3idx) := NUL; return To_Ghdl_C_String (Tmpstring3'Address); end ii_vpi_get_value_bin_str; procedure vpi_get_value (Expr : vpiHandle; Value : p_vpi_value) is begin Vpi_Trace ("vpi_get_value"); case Value.Format is when vpiObjTypeVal=> -- fill in the object type and value: -- For an integer, vpiIntVal -- For a real, vpiRealVal -- For a scalar, either vpiScalar or vpiStrength -- For a time variable, vpiTimeVal with vpiSimTime -- For a vector, vpiVectorVal dbgPut_Line ("vpi_get_value: vpiObjTypeVal"); when vpiBinStrVal=> Value.Str := ii_vpi_get_value_bin_str (Expr.Ref); --aValue.mStr := NulTerminate2(aExpr.mRef.Name.all); when vpiOctStrVal=> dbgPut_Line("vpi_get_value: vpiNet, vpiOctStrVal"); when vpiDecStrVal=> dbgPut_Line("vpi_get_value: vpiNet, vpiDecStrVal"); when vpiHexStrVal=> dbgPut_Line("vpi_get_value: vpiNet, vpiHexStrVal"); when vpiScalarVal=> dbgPut_Line("vpi_get_value: vpiNet, vpiScalarVal"); when vpiIntVal=> case Expr.mType is when vpiLeftRange | vpiRightRange=> declare Info : Verilog_Wire_Info; begin Get_Verilog_Wire (Expr.Ref, Info); if Info.Irange /= null then if Expr.mType = vpiLeftRange then Value.Integer_m := Integer (Info.Irange.I32.Left); else Value.Integer_m := Integer (Info.Irange.I32.Right); end if; else Value.Integer_m := 0; end if; end; when others=> dbgPut_Line ("vpi_get_value: vpiIntVal, unknown mType"); end case; when vpiRealVal=> dbgPut_Line("vpi_get_value: vpiRealVal"); when vpiStringVal=> dbgPut_Line("vpi_get_value: vpiStringVal"); when vpiTimeVal=> dbgPut_Line("vpi_get_value: vpiTimeVal"); when vpiVectorVal=> dbgPut_Line("vpi_get_value: vpiVectorVal"); when vpiStrengthVal=> dbgPut_Line("vpi_get_value: vpiStrengthVal"); when others=> dbgPut_Line("vpi_get_value: unknown mFormat"); end case; end vpi_get_value; ------------------------------------------------------------------------ -- void vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, -- p_vpi_time when, int flags) -- Alter the simulation value of an object. -- see IEEE 1364-2001, chapter 27.14, page 675 -- FIXME type Std_Ulogic_Array is array (Ghdl_Index_Type range <>) of Std_Ulogic; procedure Ii_Vpi_Put_Value (Info : Verilog_Wire_Info; Vec : Std_Ulogic_Array) is begin case Info.Kind is when Vcd_Bad => return; when Vcd_Bit | Vcd_Bool | Vcd_Bitvector => for J in Vec'Range loop declare V : constant Ghdl_B1 := Ghdl_B1 (Vec (J) = '1' or Vec (J) = 'H'); begin case Info.Val is when Vcd_Effective => Ghdl_Signal_Force_Effective_B1 (Info.Sigs (J), V); when Vcd_Driving => Ghdl_Signal_Force_Driving_B1 (Info.Sigs (J), V); end case; end; end loop; when Vcd_Stdlogic | Vcd_Stdlogic_Vector => for J in Vec'Range loop declare V : constant Ghdl_E8 := Std_Ulogic'Pos (Vec (J)); begin case Info.Val is when Vcd_Effective => Ghdl_Signal_Force_Effective_E8 (Info.Sigs (J), V); when Vcd_Driving => Ghdl_Signal_Force_Driving_E8 (Info.Sigs (J), V); end case; end; end loop; when Vcd_Integer32 | Vcd_Float64 => null; end case; end Ii_Vpi_Put_Value; procedure Ii_Vpi_Put_Value_Int (Info : Verilog_Wire_Info; Len : Ghdl_Index_Type; Val : Unsigned_32) is V : Unsigned_32; Vec : Std_Ulogic_Array (0 .. Len - 1); begin V := Val; for J in reverse 0 .. Len - 1 loop if (V mod 2) = 0 then Vec (J) := '0'; else Vec (J) := '1'; end if; V := Shift_Right_Arithmetic (V, 1); end loop; Ii_Vpi_Put_Value (Info, Vec); end Ii_Vpi_Put_Value_Int; procedure Ii_Vpi_Put_Value_Bin_Str (Info : Verilog_Wire_Info; Len : Ghdl_Index_Type; Str : Ghdl_C_String) is Slen : constant Natural := strlen (Str); Soff : Integer; Vec : Std_Ulogic_Array (0 .. Len - 1); V : Std_Ulogic; begin Soff := Slen; for J in reverse 0 .. Len - 1 loop Soff := Soff - 1; if Soff >= 0 then case Str (Str'First + Soff) is when 'u' | 'U' => V := 'U'; when 'x' | 'X' => V := 'X'; when '0' => V := '0'; when '1' => V := '1'; when 'z' | 'Z' => V := 'Z'; when 'w' | 'W' => V := 'W'; when 'l' | 'L' => V := 'L'; when 'h' | 'H' => V := 'H'; when '-' => V := '-'; when others => V := 'U'; end case; else V := '0'; end if; Vec (J) := V; end loop; Ii_Vpi_Put_Value (Info, Vec); end Ii_Vpi_Put_Value_Bin_Str; -- vpiHandle vpi_put_value(vpiHandle obj, p_vpi_value value, -- p_vpi_time when, int flags) function vpi_put_value (aObj : vpiHandle; aValue : p_vpi_value; aWhen : p_vpi_time; aFlags : integer) return vpiHandle is pragma Unreferenced (aWhen); pragma Unreferenced (aFlags); function To_Unsigned_32 is new Ada.Unchecked_Conversion (Integer, Unsigned_32); Info : Verilog_Wire_Info; Len : Ghdl_Index_Type; begin Vpi_Trace ("vpi_put_value"); Reset_Error; -- A very simple write procedure for VPI. -- Basically, it accepts bin_str values and converts to appropriate -- types (only std_logic and bit values and vectors). -- It'll use Set_Effective_Value procedure to update signals -- Ignoring aWhen and aFlags, for now. -- Check the Obj type. -- * The vpiHandle has a reference (field Ref) to a VhpiHandleT -- when it doesnt come from a callback. case Vhpi_Get_Kind (aObj.Ref) is when VhpiPortDeclK | VhpiSigDeclK => null; when others => return null; end case; -- The following code segment was copied from the -- ii_vpi_get_value function. -- Get verilog compat info. Get_Verilog_Wire (aObj.Ref, Info); if Info.Kind = Vcd_Bad then return null; end if; if Info.Irange = null then Len := 1; else Len := Info.Irange.I32.Len; if Len = 0 then -- No signal. return null; end if; end if; -- Step 1: convert vpi object to internal format. -- p_vpi_handle -> Ghdl_Signal_Ptr -- To_Signal_Arr_Ptr (Info.Addr) does part of the magic -- Step 2: convert datum to appropriate type. -- Ghdl_C_String -> Value_Union -- Step 3: assigns value to object using Set_Effective_Value -- call (from grt-signals) -- Set_Effective_Value(sig_ptr, conv_value); -- Checks the format of aValue. Only vpiBinStrVal will be accepted -- for now. case aValue.Format is when vpiObjTypeVal => dbgPut_Line ("vpi_put_value: vpiObjTypeVal"); when vpiBinStrVal => Ii_Vpi_Put_Value_Bin_Str (Info, Len, aValue.Str); -- dbgPut_Line ("vpi_put_value: vpiBinStrVal"); when vpiOctStrVal => dbgPut_Line ("vpi_put_value: vpiNet, vpiOctStrVal"); when vpiDecStrVal => dbgPut_Line ("vpi_put_value: vpiNet, vpiDecStrVal"); when vpiHexStrVal => dbgPut_Line ("vpi_put_value: vpiNet, vpiHexStrVal"); when vpiScalarVal => dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); when vpiIntVal => Ii_Vpi_Put_Value_Int (Info, Len, To_Unsigned_32 (aValue.Integer_m)); -- dbgPut_Line ("vpi_put_value: vpiIntVal"); when vpiRealVal => dbgPut_Line("vpi_put_value: vpiRealVal"); when vpiStringVal => dbgPut_Line("vpi_put_value: vpiStringVal"); when vpiTimeVal => dbgPut_Line("vpi_put_value: vpiTimeVal"); when vpiVectorVal => dbgPut_Line("vpi_put_value: vpiVectorVal"); when vpiStrengthVal => dbgPut_Line("vpi_put_value: vpiStrengthVal"); when others => dbgPut_Line("vpi_put_value: unknown mFormat"); end case; -- Must return a scheduled event caused by vpi_put_value() -- Still dont know how to do it. return null; end vpi_put_value; ------------------------------------------------------------------------ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); -- see IEEE 1364-2001, page xxx procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) is function To_Unsigned_64 is new Ada.Unchecked_Conversion (Std_Time, Unsigned_64); V : Unsigned_64; begin Vpi_Trace ("vpi_get_time"); if Obj /= null or else Time.mType /= vpiSimTime then dbgPut_Line ("vpi_get_time: unhandled"); return; end if; V := To_Unsigned_64 (Current_Time) / 1000; Time.mHigh := Unsigned_32 (V / 2 ** 32); Time.mLow := Unsigned_32 (V mod 2 ** 32); Time.mReal := 0.0; end vpi_get_time; ------------------------------------------------------------------------ type Callback_List is record First, Last : vpiHandle; end record; procedure Append_Callback (List : in out Callback_List; Hand : vpiHandle) is begin if List.First = null then List.First := Hand; else List.Last.Cb_Next := Hand; Hand.Cb_Prev := List.Last; end if; List.Last := Hand; Hand.Cb_Next := null; end Append_Callback; procedure Execute_Callback (Hand : vpiHandle) is Res : Integer; pragma Unreferenced (Res); begin Res := Hand.Cb.Cb_Rtn (Hand.Cb'Access); end Execute_Callback; procedure Execute_Callback_List (List : Callback_List) is H, Next_H : vpiHandle; begin H := List.First; while H /= null loop Next_H := H.Cb_Next; -- The callback may destroy h. Execute_Callback (H); H := Next_H; end loop; end Execute_Callback_List; -- vpiHandle vpi_register_cb(p_cb_data data) g_cbEndOfCompile : Callback_List; g_cbStartOfSimulation : Callback_List; g_cbEndOfSimulation : Callback_List; function To_Address is new Ada.Unchecked_Conversion (vpiHandle, System.Address); function To_vpiHandle is new Ada.Unchecked_Conversion (System.Address, vpiHandle); procedure Call_Callback (Arg : System.Address) is Hand : constant vpiHandle := To_vpiHandle (Arg); begin Vpi_Trace ("vpi: call callback"); Execute_Callback (Hand); end Call_Callback; procedure Call_Valuechange_Callback (Arg : System.Address) is Hand : constant vpiHandle := To_vpiHandle (Arg); begin if Verilog_Wire_Event (Hand.Cb_Wire) then -- Note: the call may remove H from the list, or even -- destroy it. -- However, we assume it doesn't remove the next callback... Vpi_Trace ("vpi: call valuechange cb"); Execute_Callback (Hand); end if; end Call_Valuechange_Callback; procedure Resched_Callback (Arg : System.Address) is Hand : constant vpiHandle := To_vpiHandle (Arg); begin case Hand.Cb.Reason is when cbReadOnlySynch => Register_Callback (Cb_End_Of_Time_Step, Hand.Cb_Handle, Oneshot, Call_Callback'Access, Arg); when cbReadWriteSynch => Register_Callback (Cb_Last_Known_Delta, Hand.Cb_Handle, Oneshot, Call_Callback'Access, Arg); when others => raise Program_Error; end case; end Resched_Callback; function vpi_register_cb (Data : p_cb_data) return vpiHandle is Res : vpiHandle; T : Std_Time; begin Vpi_Trace ("vpi_register_cb"); Res := new struct_vpiHandle (vpiCallback); Res.Cb := Data.all; case Data.Reason is when cbEndOfCompile => Append_Callback (g_cbEndOfCompile, Res); when cbStartOfSimulation => Append_Callback (g_cbStartOfSimulation, Res); when cbEndOfSimulation => Append_Callback (g_cbEndOfSimulation, Res); when cbValueChange => Get_Verilog_Wire (Data.Obj.Ref, Res.Cb_Wire); Register_Callback (Cb_Signals_Updated, Res.Cb_Handle, Repeat, Call_Valuechange_Callback'Access, To_Address (Res)); when cbReadOnlySynch | cbReadWriteSynch => T := Vpi_Time_To_Time (Data.Time.all); if T = 0 then Resched_Callback (To_Address (Res)); else Register_Callback_At (Cb_After_Delay, Res.Cb_Handle, Current_Time + T, Resched_Callback'Access, To_Address (Res)); end if; when cbAfterDelay => T := Vpi_Time_To_Time (Data.Time.all); Register_Callback_At (Cb_After_Delay, Res.Cb_Handle, Current_Time + T, Call_Callback'Access, To_Address (Res)); when cbNextSimTime => Register_Callback (Cb_Next_Time_Step, Res.Cb_Handle, Repeat, Call_Callback'Access, To_Address (Res)); when others => dbgPut_Line ("vpi_register_cb: unknown reason"); Free (Res); return null; end case; return Res; end vpi_register_cb; ------------------------------------------------------------------------------- -- * * * V P I d u m m i e s * * * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------- -- int vpi_free_object(vpiHandle ref) function vpi_free_object (aRef: vpiHandle) return integer is pragma Unreferenced (aRef); begin return 1; end vpi_free_object; -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) function vpi_get_vlog_info (info : p_vpi_vlog_info) return integer is begin Vpi_Trace ("vpi_get_vlog_info"); info.all := (Argc => 0, Argv => Null_Address, Product => To_Ghdl_C_String (Product'Address), Version => To_Ghdl_C_String (Version'Address)); return 0; end vpi_get_vlog_info; -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) function vpi_handle_by_index (aRef: vpiHandle; aIndex: integer) return vpiHandle is pragma Unreferenced (aRef); pragma Unreferenced (aIndex); begin return null; end vpi_handle_by_index; -- Return True iff L and R are equal. L must not have an element set to -- NUL. function Strcmp (L : String; R : Ghdl_C_String) return Boolean is begin if L'Last < L'First - 1 then -- Handle null string. return R (1) = NUL; end if; for I in L'Range loop if L (I) = NUL then -- NUL not allowed in L. return False; end if; if L (I) /= R (I - L'First + 1) then return False; end if; end loop; -- R is NUL terminated. return R (L'Length + 1) = NUL; end Strcmp; procedure Find_By_Name (Scope : VhpiHandleT; Rel : VhpiOneToManyT; Name : String; Res : out VhpiHandleT; Err : out AvhpiErrorT) is It : VhpiHandleT; El_Name : Ghdl_C_String; begin Vhpi_Iterator (Rel, Scope, It, Err); if Err /= AvhpiErrorOk then return; end if; loop Vhpi_Scan (It, Res, Err); -- Either a real error or end of iterator. exit when Err /= AvhpiErrorOk; El_Name := Avhpi_Get_Base_Name (Res); exit when Strcmp (Name , El_Name); end loop; end Find_By_Name; function vpi_handle_by_name (Name : Ghdl_C_String; Scope : vpiHandle) return vpiHandle is B, E : Natural; Base, El : VhpiHandleT; Err : AvhpiErrorT; Prop : Integer; begin Vpi_Trace ("vpi_handle_by_name"); -- Extract the start point. if Scope = null then Get_Root_Scope (Base); else Base := Scope.Ref; end if; B := Name'First; -- Iterate on each part of Name. loop exit when Name (B) = NUL; -- Extract the next part of the name. declare C : Character; begin E := B; loop C := Name (E + 1); exit when C = NUL or C = '.'; E := E + 1; end loop; end; -- Find name in Base, first as a decl, then as a sub-region. Find_By_Name (Base, VhpiDecls, Name (B .. E), El, Err); if Err /= AvhpiErrorOk then Find_By_Name (Base, VhpiInternalRegions, Name (B .. E), El, Err); end if; if Err = AvhpiErrorOk then -- Found! Base := El; else -- Not found. return null; end if; -- Next path component. B := E + 1; exit when Name (B) = NUL; pragma Assert (Name (B) = '.'); B := B + 1; end loop; Prop := Vhpi_Handle_To_Vpi_Prop (Base); if Prop /= vpiUndefined then return Build_vpiHandle (Base, Prop); else return null; end if; end vpi_handle_by_name; -- unsigned int vpi_mcd_close(unsigned int mcd) function vpi_mcd_close (Mcd: integer) return integer is pragma Unreferenced (Mcd); begin return 0; end vpi_mcd_close; -- char *vpi_mcd_name(unsigned int mcd) function vpi_mcd_name (Mcd: integer) return integer is pragma Unreferenced (Mcd); begin return 0; end vpi_mcd_name; -- unsigned int vpi_mcd_open(char *name) function vpi_mcd_open (Name : Ghdl_C_String) return Integer is pragma Unreferenced (Name); begin return 0; end vpi_mcd_open; -- void vpi_register_systf(const struct t_vpi_systf_data*ss) procedure vpi_register_systf(aSs: System.Address) is pragma Unreferenced (aSs); begin Vpi_Trace ("vpi_register_systf"); end vpi_register_systf; -- int vpi_remove_cb(vpiHandle ref) function vpi_remove_cb (Ref : vpiHandle) return Integer is Ref_Copy : vpiHandle; begin Vpi_Trace ("vpi_remove_cb"); case Ref.Cb.Reason is when cbValueChange => Delete_Callback (Ref.Cb_Handle); when cbReadWriteSynch | cbReadOnlySynch => Delete_Callback (Ref.Cb_Handle); when others => return 0; end case; Ref_Copy := Ref; Free (Ref_Copy); return 1; end vpi_remove_cb; -- void vpi_vprintf(const char*fmt, va_list ap) procedure vpi_vprintf (Fmt : Address; Ap : Address) is pragma Unreferenced (Fmt); pragma Unreferenced (Ap); begin null; end vpi_vprintf; -- missing here, see grt-cvpi.c: -- vpi_mcd_open_x -- vpi_mcd_vprintf -- vpi_mcd_fputc -- vpi_mcd_fgetc -- vpi_sim_vcontrol -- vpi_chk_error -- vpi_handle_by_name Default_Message : constant String := "(no error message)" & NUL; Unknown_File : constant String := "(no file)" & NUL; Err_Message : Ghdl_C_String := To_Ghdl_C_String (Default_Message'Address); Err_Code : Ghdl_C_String := null; Err_File : Ghdl_C_String := To_Ghdl_C_String (Unknown_File'Address); Err_Line : Integer := 0; Err_Status : Integer := 0; procedure Reset_Error is begin Err_Message := To_Ghdl_C_String (Default_Message'Address); Err_Code := null; Err_File := To_Ghdl_C_String (Unknown_File'Address); Err_Line := 0; Err_Status := 0; end Reset_Error; function vpi_chk_error (Info : p_vpi_error_info) return Integer is begin if Info /= null then Info.all := (State => vpiRun, Level => vpiError, Message => Err_Message, Product => To_Ghdl_C_String (Product'Address), Code => Err_Code, File => Err_File, Line => Err_Line); end if; return Err_Status; end vpi_chk_error; function vpi_control (Op : Integer; Status : Integer) return Integer is pragma Unreferenced (Status); begin Vpi_Trace ("vpi_control"); case Op is when vpiFinish | vpiStop => Options.Break_Simulation := True; return 1; when others => return 0; end case; end vpi_control; ------------------------------------------------------------------------------ -- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------ -- VCD filename. Vpi_Filename : String_Access := null; ------------------------------------------------------------------------ -- Return TRUE if OPT is an option for VPI. function Vpi_Option (Opt : String) return Boolean is F : constant Natural := Opt'First; begin if Opt'Length < 5 or else Opt (F .. F + 4) /= "--vpi" then return False; end if; if Opt'Length > 6 and then Opt (F + 5) = '=' then -- Add an extra NUL character. Vpi_Filename := new String (1 .. Opt'Length - 6 + 1); Vpi_Filename (1 .. Opt'Length - 6) := Opt (F + 6 .. Opt'Last); Vpi_Filename (Vpi_Filename'Last) := NUL; return True; elsif Opt = "--vpi-trace" then Flag_Trace := True; return True; else return False; end if; end Vpi_Option; ------------------------------------------------------------------------ procedure Vpi_Help is begin Put_Line (" --vpi=FILENAME load VPI module"); end Vpi_Help; ------------------------------------------------------------------------ -- Called before elaboration. -- void loadVpiModule(const char* modulename) function LoadVpiModule (Filename: Address) return Integer; pragma Import (C, LoadVpiModule, "loadVpiModule"); procedure Vpi_Init is begin if Vpi_Filename /= null then if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then Error ("cannot load VPI module"); end if; end if; end Vpi_Init; ------------------------------------------------------------------------ -- Called after elaboration. procedure Vpi_Start is Res : Integer; pragma Unreferenced (Res); begin if Vpi_Filename = null then return; end if; Grt.Rtis_Types.Search_Types_RTI; Execute_Callback_List (g_cbEndOfCompile); Execute_Callback_List (g_cbStartOfSimulation); end Vpi_Start; ------------------------------------------------------------------------ -- Called at the end of the simulation. procedure Vpi_End is Res : Integer; pragma Unreferenced (Res); begin Execute_Callback_List (g_cbEndOfSimulation); end Vpi_End; Vpi_Hooks : aliased constant Hooks_Type := (Desc => new String'("vpi: vpi compatible API"), Option => Vpi_Option'Access, Help => Vpi_Help'Access, Init => Vpi_Init'Access, Start => Vpi_Start'Access, Finish => Vpi_End'Access); procedure Register is begin Register_Hooks (Vpi_Hooks'Access); end Register; end Grt.Vpi;