From ce10f7dbd57cb5d2273567aa536bfce79620849c Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Fri, 30 Oct 2015 07:11:28 +0100 Subject: Rework callbacks, support cocotb. --- src/grt/grt-avhpi.adb | 116 +++--- src/grt/grt-avhpi.ads | 12 +- src/grt/grt-callbacks.adb | 207 +++++++++++ src/grt/grt-callbacks.ads | 107 ++++++ src/grt/grt-cvpi.c | 31 +- src/grt/grt-disp_signals.adb | 3 +- src/grt/grt-errors.adb | 3 +- src/grt/grt-errors.ads | 13 +- src/grt/grt-fst.adb | 7 +- src/grt/grt-hooks.adb | 2 - src/grt/grt-hooks.ads | 22 ++ src/grt/grt-main.adb | 4 - src/grt/grt-options.adb | 28 +- src/grt/grt-options.ads | 7 +- src/grt/grt-processes.adb | 227 ++++++++---- src/grt/grt-processes.ads | 3 - src/grt/grt-rtis_addr.adb | 6 +- src/grt/grt-signals.adb | 179 +++++++-- src/grt/grt-signals.ads | 51 +-- src/grt/grt-std_logic_1164.ads | 2 +- src/grt/grt-types.ads | 3 - src/grt/grt-vcd.adb | 35 +- src/grt/grt-vcd.ads | 4 + src/grt/grt-vpi.adb | 799 ++++++++++++++++++++++++++++------------- src/grt/grt-vpi.ads | 116 ++++-- src/grt/grt-waves.adb | 12 +- 26 files changed, 1505 insertions(+), 494 deletions(-) create mode 100644 src/grt/grt-callbacks.adb create mode 100644 src/grt/grt-callbacks.ads diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb index 535cb0ad3..75bc946a5 100644 --- a/src/grt/grt-avhpi.adb +++ b/src/grt/grt-avhpi.adb @@ -27,15 +27,21 @@ with Grt.Vstrings; use Grt.Vstrings; with Grt.Rtis_Utils; use Grt.Rtis_Utils; package body Grt.Avhpi is - procedure Get_Root_Inst (Res : out VhpiHandleT) - is + procedure Get_Root_Inst (Res : out VhpiHandleT) is begin Res := (Kind => VhpiRootInstK, Ctxt => Get_Top_Context); end Get_Root_Inst; + procedure Get_Root_Scope (Res : out VhpiHandleT) is + begin + Res := (Kind => AvhpiRootScopeK, + Ctxt => Null_Context); + end Get_Root_Scope; + procedure Get_Package_Inst (Res : out VhpiHandleT) is begin + -- Ctxt is the list of instantiated packages. Res := (Kind => VhpiIteratorK, Ctxt => (Base => Null_Address, Block => To_Ghdl_Rti_Access (Ghdl_Rti_Top'Address)), @@ -63,8 +69,7 @@ package body Grt.Avhpi is procedure Vhpi_Iterator (Rel : VhpiOneToManyT; Ref : VhpiHandleT; Res : out VhpiHandleT; - Error : out AvhpiErrorT) - is + Error : out AvhpiErrorT) is begin -- Default value in case of success. Res := (Kind => VhpiIteratorK, @@ -89,6 +94,14 @@ package body Grt.Avhpi is when VhpiCompInstStmtK => Get_Instance_Context (Ref.Inst, Ref.Ctxt, Res.Ctxt); return; + when AvhpiRootScopeK => + Res := (Kind => AvhpiRootScopeIteratorK, + Ctxt => Ref.Ctxt, + Rel => Rel, + It_Cur => 0, + It2 => 0, + Max2 => 0); + return; when others => null; end case; @@ -337,6 +350,19 @@ package body Grt.Avhpi is end loop; end Vhpi_Scan_Internal_Regions; + procedure Vhpi_Scan_Root_Design (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) is + begin + if Iterator.It_Cur = 0 then + Get_Root_Inst (Res); + Iterator.It_Cur := 1; + Error := AvhpiErrorOk; + else + Error := AvhpiErrorIteratorEnd; + end if; + end Vhpi_Scan_Root_Design; + procedure Rti_To_Handle (Rti : Ghdl_Rti_Access; Ctxt : Rti_Context; Res : out VhpiHandleT) @@ -475,49 +501,55 @@ package body Grt.Avhpi is Error := AvhpiErrorIteratorEnd; end Vhpi_Scan_Decls; - procedure Vhpi_Scan (Iterator : in out VhpiHandleT; - Res : out VhpiHandleT; - Error : out AvhpiErrorT) + procedure Vhpi_Scan_Pack_Insts (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) is + Blk : Ghdl_Rtin_Block_Acc; begin - if Iterator.Kind = AvhpiNameIteratorK then - case Iterator.N_Type.Kind is - when Ghdl_Rtik_Subtype_Array => - Vhpi_Scan_Indexed_Name (Iterator, Res, Error); - when others => - Error := AvhpiErrorHandle; - Res := Null_Handle; - end case; - return; - elsif Iterator.Kind /= VhpiIteratorK then - Error := AvhpiErrorHandle; - Res := Null_Handle; + Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); + if Iterator.It_Cur >= Blk.Nbr_Child then + Error := AvhpiErrorIteratorEnd; return; end if; + Res := (Kind => VhpiPackInstK, + Ctxt => (Base => Null_Address, + Block => Blk.Children (Iterator.It_Cur))); + Iterator.It_Cur := Iterator.It_Cur + 1; + Error := AvhpiErrorOk; + end Vhpi_Scan_Pack_Insts; - case Iterator.Rel is - when VhpiPackInsts => - declare - Blk : Ghdl_Rtin_Block_Acc; - begin - Blk := To_Ghdl_Rtin_Block_Acc (Iterator.Ctxt.Block); - if Iterator.It_Cur >= Blk.Nbr_Child then - Error := AvhpiErrorIteratorEnd; - return; - end if; - Res := (Kind => VhpiPackInstK, - Ctxt => (Base => Null_Address, - Block => Blk.Children (Iterator.It_Cur))); - Iterator.It_Cur := Iterator.It_Cur + 1; - Error := AvhpiErrorOk; - end; - when VhpiInternalRegions => - Vhpi_Scan_Internal_Regions (Iterator, Res, Error); - when VhpiDecls => - Vhpi_Scan_Decls (Iterator, Res, Error); + procedure Vhpi_Scan (Iterator : in out VhpiHandleT; + Res : out VhpiHandleT; + Error : out AvhpiErrorT) + is + begin + case Iterator.Kind is + when AvhpiNameIteratorK => + case Iterator.N_Type.Kind is + when Ghdl_Rtik_Subtype_Array => + Vhpi_Scan_Indexed_Name (Iterator, Res, Error); + when others => + Error := AvhpiErrorHandle; + Res := Null_Handle; + end case; + when VhpiIteratorK => + case Iterator.Rel is + when VhpiPackInsts => + Vhpi_Scan_Pack_Insts (Iterator, Res, Error); + when VhpiInternalRegions => + Vhpi_Scan_Internal_Regions (Iterator, Res, Error); + when VhpiDecls => + Vhpi_Scan_Decls (Iterator, Res, Error); + when others => + Res := Null_Handle; + Error := AvhpiErrorNotImplemented; + end case; + when AvhpiRootScopeIteratorK => + Vhpi_Scan_Root_Design (Iterator, Res, Error); when others => + Error := AvhpiErrorHandle; Res := Null_Handle; - Error := AvhpiErrorNotImplemented; end case; end Vhpi_Scan; @@ -539,7 +571,9 @@ package body Grt.Avhpi is declare Blk : Ghdl_Rtin_Block_Acc; begin + -- Get top architecture. Blk := To_Ghdl_Rtin_Block_Acc (Obj.Ctxt.Block); + -- From architecture to entity. Blk := To_Ghdl_Rtin_Block_Acc (Blk.Parent); return Blk.Name; end; @@ -1240,5 +1274,3 @@ package body Grt.Avhpi is return AvhpiErrorOk; end Vhpi_Put_Value; end Grt.Avhpi; - - diff --git a/src/grt/grt-avhpi.ads b/src/grt/grt-avhpi.ads index b61b1ff8a..9609882e7 100644 --- a/src/grt/grt-avhpi.ads +++ b/src/grt/grt-avhpi.ads @@ -154,7 +154,11 @@ package Grt.Avhpi is VhpiWhileLoopK, -- Iterator, but on a name. - AvhpiNameIteratorK + AvhpiNameIteratorK, + + -- Root scope that contains the top entity. For vpi. + AvhpiRootScopeK, + AvhpiRootScopeIteratorK ); type VhpiOneToOneT is @@ -416,6 +420,9 @@ package Grt.Avhpi is -- Get the root instance. procedure Get_Root_Inst (Res : out VhpiHandleT); + -- For vpi: the scope that contains the root instance. + procedure Get_Root_Scope (Res : out VhpiHandleT); + -- Get the instanciated packages. procedure Get_Package_Inst (Res : out VhpiHandleT); @@ -522,7 +529,8 @@ private Ctxt : Rti_Context; case Kind is - when VhpiIteratorK => + when VhpiIteratorK + | AvhpiRootScopeIteratorK => Rel : VhpiOneToManyT; It_Cur : Ghdl_Index_Type; It2 : Ghdl_Index_Type; diff --git a/src/grt/grt-callbacks.adb b/src/grt/grt-callbacks.adb new file mode 100644 index 000000000..fba404834 --- /dev/null +++ b/src/grt/grt-callbacks.adb @@ -0,0 +1,207 @@ +-- GHDL Run Time (GRT) - Callbacks. +-- 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. + +package body Grt.Callbacks is + Recycled_Handles : Callback_Handle := null; + + procedure Free_Handle (Hand : Callback_Handle) is + begin + Hand.Next := Recycled_Handles; + Recycled_Handles := Hand; + end Free_Handle; + + function Allocate_Handle return Callback_Handle + is + Res : Callback_Handle; + begin + Res := Recycled_Handles; + if Res = null then + return new Cb_Cell; + else + Recycled_Handles := Res.Next; + return Res; + end if; + end Allocate_Handle; + + procedure Register_Callback_At + (List : in out Callback_Time_List; + Handle : out Callback_Handle; + T : Std_Time; + Proc : Callback_Acc; + Arg : System.Address := System.Null_Address) + is + Last, Cur : Callback_Handle; + begin + Handle := Allocate_Handle; + Handle.all := (T => T, Mode => Timed, + Proc => Proc, Arg => Arg, Next => null); + + Last := null; + Cur := List.First; + + -- Insert after timeouts before (<=) T. + while Cur /= null loop + exit when Cur.T > T; + Last := Cur; + Cur := Cur.Next; + end loop; + + if Last = null then + -- At head. + Handle.Next := List.First; + List.First := Handle; + List.First_Timeout := T; + else + pragma Assert (Cur = Last.Next); + Handle.Next := Cur; + Last.Next := Handle; + end if; + end Register_Callback_At; + + procedure Call_Time_Callbacks (List : in out Callback_Time_List) + is + C : Callback_Handle; + begin + pragma Assert (List.First_Timeout = Current_Time); + + loop + C := List.First; + if C = null then + -- No more callback. + List.First_Timeout := Std_Time'Last; + exit; + elsif C.T > Current_Time then + -- No more callbacks for current time. + List.First_Timeout := C.T; + exit; + end if; + + List.First := C.Next; + + -- Calling the callback may have side effects, like adding a new + -- callback. They should be in the future. + declare + Proc : constant Callback_Acc := C.Proc; + Arg : constant System.Address := C.Arg; + begin + Free_Handle (C); + Proc.all (Arg); + end; + end loop; + end Call_Time_Callbacks; + + procedure Register_Callback + (List : in out Callback_List; + Handle : out Callback_Handle; + Mode : Callback_Mode; + Proc : Callback_Acc; + Arg : System.Address := System.Null_Address) is + begin + Handle := Allocate_Handle; + Handle.all := (T => 0, Mode => Mode, + Proc => Proc, Arg => Arg, Next => null); + + -- Append. + if List.First = null then + pragma Assert (List.Last = null); + List.First := Handle; + else + pragma Assert (List.Last /= null); + List.Last.Next := Handle; + end if; + List.Last := Handle; + end Register_Callback; + + procedure Call_Callbacks (List : in out Callback_List) + is + -- Last cell to call. Newly appended cells are not executed. + Last : constant Callback_Handle := List.Last; + + Cell, Next_Cell, Prev_Cell : Callback_Handle; + begin + Cell := List.First; + + if Cell = null then + return; + end if; + + Prev_Cell := null; + loop + -- First, call the callback. This may change the queue (for example + -- append a new callback and therefore change the next link of that + -- cell). + declare + Proc : constant Callback_Acc := Cell.Proc; + Arg : constant System.Address := Cell.Arg; + begin + Proc.all (Arg); + end; + + Next_Cell := Cell.Next; + if Cell.Mode = Oneshot then + if Prev_Cell = null then + -- First cell of the list, update head. + List.First := Next_Cell; + else + Prev_Cell.Next := Next_Cell; + end if; + if Next_Cell = null then + List.Last := Prev_Cell; + end if; + Free_Handle (Cell); + else + Prev_Cell := Cell; + end if; + exit when Cell = Last; + Cell := Next_Cell; + end loop; + end Call_Callbacks; + + procedure Nop_Callback (Arg : System.Address) is + begin + null; + end Nop_Callback; + + procedure Delete_Callback (Handle : Callback_Handle) is + begin + Handle.Proc := Nop_Callback'Access; + + if Handle.Mode = Repeat then + -- Be sure the callback will be removed at the next call. + Handle.Mode := Oneshot; + end if; + end Delete_Callback; + + function Get_First_Time (List : Callback_Time_List) return Std_Time is + begin + return List.First_Timeout; + end Get_First_Time; + + function Has_Callbacks (List : Callback_List) return Boolean is + begin + return List.First /= null; + end Has_Callbacks; + +end Grt.Callbacks; diff --git a/src/grt/grt-callbacks.ads b/src/grt/grt-callbacks.ads new file mode 100644 index 000000000..05d01b3eb --- /dev/null +++ b/src/grt/grt-callbacks.ads @@ -0,0 +1,107 @@ +-- GHDL Run Time (GRT) - Callbacks. +-- 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; + +-- Callbacks are user registered procedures that are called during simulation. +-- They are used to implement vpi/vhpi callbacks, but also some features like +-- vcd or fst. + +package Grt.Callbacks is + pragma Preelaborate (Grt.Callbacks); + + -- It would be nice to use OOP (tagged types and overriding), but this is + -- not anymore available in the context of pragma No_Run_Time. + -- Furthermore, that wouldn't be that convenient because of lack of + -- multiple inheritance. + -- + -- Thus the use of a 'generic' callback type. The type Address is used for + -- any pointer type. + type Callback_Acc is access procedure (Arg : System.Address); + + type Callback_Handle is private; + + type Callback_List is limited private; + pragma Preelaborable_Initialization (Callback_List); + + type Callback_Time_List is limited private; + pragma Preelaborable_Initialization (Callback_Time_List); + + -- Register a timeout: PROC will be called with parameter ARG at time T + -- at the beginning of the cycle (before any process). Insertion is O(n). + procedure Register_Callback_At + (List : in out Callback_Time_List; + Handle : out Callback_Handle; + T : Std_Time; + Proc : Callback_Acc; + Arg : System.Address := System.Null_Address); + + type Callback_Mode is (Timed, Repeat, Oneshot); + subtype Callback_Non_Timed_Mode is Callback_Mode range Repeat .. Oneshot; + + procedure Register_Callback + (List : in out Callback_List; + Handle : out Callback_Handle; + Mode : Callback_Mode; + Proc : Callback_Acc; + Arg : System.Address := System.Null_Address); + + -- Delete callback. + -- In fact the callback is just marked as deleted, but will be removed + -- only at the point it would be called. + procedure Delete_Callback (Handle : Callback_Handle); + + -- Call the callbacks. + procedure Call_Callbacks (List : in out Callback_List); + procedure Call_Time_Callbacks (List : in out Callback_Time_List); + + -- Return the date of the earliest callbacks (or Std_Time'Last if none). + function Get_First_Time (List : Callback_Time_List) return Std_Time; + pragma Inline (Get_First_Time); + + -- Return True if there is at least one callback in the list. + function Has_Callbacks (List : Callback_List) return Boolean; + pragma Inline (Has_Callbacks); +private + type Cb_Cell; + type Callback_Handle is access Cb_Cell; + + type Cb_Cell is record + T : Std_Time; + Mode : Callback_Mode; + Proc : Callback_Acc; + Arg : System.Address; + Next : Callback_Handle; + end record; + + type Callback_List is limited record + First, Last : Callback_Handle := null; + end record; + + type Callback_Time_List is limited record + First : Callback_Handle := null; + First_Timeout : Std_Time := Std_Time'Last; + end record; +end Grt.Callbacks; diff --git a/src/grt/grt-cvpi.c b/src/grt/grt-cvpi.c index 51edd678f..3e427c551 100644 --- a/src/grt/grt-cvpi.c +++ b/src/grt/grt-cvpi.c @@ -28,15 +28,7 @@ //----------------------------------------------------------------------------- // VPI callback functions typedef void *vpiHandle, *p_vpi_time, *p_vpi_value; -typedef struct t_cb_data { - int reason; - int (*cb_rtn)(struct t_cb_data*cb); - vpiHandle obj; - p_vpi_time time; - p_vpi_value value; - int index; - char*user_data; -} s_cb_data, *p_cb_data; +typedef struct t_cb_data s_cb_data, *p_cb_data; //----------------------------------------------------------------------------- // vpi thunking a la Icarus Verilog @@ -103,7 +95,7 @@ typedef struct { int vpi_register_sim(p_vpi_thunk tp); -static vpi_thunk thunkTable = +static vpi_thunk thunkTable = { VPI_THUNK_MAGIC, vpi_register_systf, vpi_vprintf, @@ -128,8 +120,8 @@ static vpi_thunk thunkTable = vpi_put_value, vpi_free_object, vpi_get_vlog_info, - 0, //vpi_chk_error, - 0 //vpi_handle_by_name + vpi_chk_error, + vpi_handle_by_name }; //----------------------------------------------------------------------------- @@ -202,7 +194,7 @@ loadVpiModule (const char* modulename) "vpi_register_sim" // w/o leading underscore: Linux }; - int i; + int i; void* vpimod; fprintf (stderr, "loading VPI module '%s'\n", modulename); @@ -223,15 +215,15 @@ loadVpiModule (const char* modulename) { void* vpithunk; void* vpitable; - + vpitable = module_symbol (vpimod, vpitablenames[i]); vpithunk = module_symbol (vpimod, vpithunknames[i]); - + if (vpithunk) { typedef int (*funT)(p_vpi_thunk tp); funT regsim; - + regsim = (funT)vpithunk; regsim (&thunkTable); } @@ -240,20 +232,20 @@ loadVpiModule (const char* modulename) // this is not an error, as the register-mechanism // is not standardized } - + if (vpitable) { unsigned int tmp; //extern void (*vlog_startup_routines[])(); typedef void (*vlog_startup_routines_t)(void); vlog_startup_routines_t *vpifuns; - + vpifuns = (vlog_startup_routines_t*)vpitable; for (tmp = 0; vpifuns[tmp]; tmp++) { vpifuns[tmp](); } - + fprintf (stderr, "VPI module loaded!\n"); return 0; // successfully registered VPI module } @@ -274,4 +266,3 @@ vpi_printf (const char *fmt, ...) //----------------------------------------------------------------------------- // end of file - diff --git a/src/grt/grt-disp_signals.adb b/src/grt/grt-disp_signals.adb index ebb249954..684a4548c 100644 --- a/src/grt/grt-disp_signals.adb +++ b/src/grt/grt-disp_signals.adb @@ -425,7 +425,7 @@ package body Grt.Disp_Signals is if Sig.S.Mode_Sig in Mode_Signal_User then Put (" #drv: "); Put_I32 (stdout, Ghdl_I32 (Sig.S.Nbr_Drivers)); - case Sig.Sig_Kind is + case Sig.Flags.Sig_Kind is when Kind_Signal_No => Put (" "); when Kind_Signal_Register => @@ -460,6 +460,7 @@ package body Grt.Disp_Signals is procedure Disp_A_Signal (Sig : Ghdl_Signal_Ptr) is begin + Put_Signal_Name (stdout, Sig); Disp_Simple_Signal (Sig, null, True); end Disp_A_Signal; diff --git a/src/grt/grt-errors.adb b/src/grt/grt-errors.adb index 66dfbf1dd..62ee86e2e 100644 --- a/src/grt/grt-errors.adb +++ b/src/grt/grt-errors.adb @@ -48,8 +48,7 @@ package body Grt.Errors is procedure Exit_Simulation is begin - -- -2 is Grt.Errors.Run_Stop - Maybe_Return_Via_Longjump (-2); + Maybe_Return_Via_Longjump (Run_Stop); Internal_Error ("exit_simulation"); end Exit_Simulation; diff --git a/src/grt/grt-errors.ads b/src/grt/grt-errors.ads index 833cded1b..bb7aab9a4 100644 --- a/src/grt/grt-errors.ads +++ b/src/grt/grt-errors.ads @@ -79,6 +79,18 @@ package Grt.Errors is Exit_Status : Integer := 0; procedure Exit_Simulation; + -- Simulation status, + -- Runtime error. + Run_Error : constant Integer := -1; + -- No process has been run. + Run_None : constant Integer := 1; + -- At least one process was run. + Run_Resumed : constant Integer := 2; + -- Simulation is finished. + Run_Finished : constant Integer := 3; + -- Stop/finish request from user (via std.env). + Run_Stop : constant Integer := 4; + -- Hook called in case of error. Error_Hook : Grt.Hooks.Proc_Hook_Type := null; @@ -89,4 +101,3 @@ private pragma Export (C, Grt_Overflow_Error, "grt_overflow_error"); pragma Export (C, Grt_Null_Access_Error, "grt_null_access_error"); end Grt.Errors; - diff --git a/src/grt/grt-fst.adb b/src/grt/grt-fst.adb index 62926688f..a87a4e1ef 100644 --- a/src/grt/grt-fst.adb +++ b/src/grt/grt-fst.adb @@ -635,9 +635,9 @@ package body Grt.Fst is procedure Fst_Cycle is begin -- Disp values. - fstWriterEmitTimeChange (Context, Unsigned_64 (Cycle_Time)); + fstWriterEmitTimeChange (Context, Unsigned_64 (Current_Time)); - if Cycle_Time = 0 then + if Current_Time = 0 then -- Disp all values. for I in Fst_Table.First .. Fst_Table.Last loop Fst_Put_Var (I); @@ -645,7 +645,8 @@ package body Grt.Fst is else -- Disp only values changed. for I in Fst_Table.First .. Fst_Table.Last loop - if Verilog_Wire_Changed (Fst_Table.Table (I).Wire, Cycle_Time) then + if Verilog_Wire_Changed (Fst_Table.Table (I).Wire, Current_Time) + then Fst_Put_Var (I); end if; end loop; diff --git a/src/grt/grt-hooks.adb b/src/grt/grt-hooks.adb index 44a9b7a41..991a3a3d6 100644 --- a/src/grt/grt-hooks.adb +++ b/src/grt/grt-hooks.adb @@ -195,5 +195,3 @@ package body Grt.Hooks is return False; end Has_Feature; end Grt.Hooks; - - diff --git a/src/grt/grt-hooks.ads b/src/grt/grt-hooks.ads index 12439088d..576ab4823 100644 --- a/src/grt/grt-hooks.ads +++ b/src/grt/grt-hooks.ads @@ -22,6 +22,8 @@ -- covered by the GNU General Public License. This exception does not -- however invalidate any other reasons why the executable file might be -- covered by the GNU Public License. +with Grt.Callbacks; + package Grt.Hooks is pragma Preelaborate (Grt.Hooks); @@ -81,4 +83,24 @@ package Grt.Hooks is -- Nil procedure. procedure Proc_Hook_Nil; + + -- Callbacks. + + -- Called at the beginning of the cycle at time T. + Cb_After_Delay : Callbacks.Callback_Time_List; + + -- Called at the beginning of a non-delta cycle. + Cb_Next_Time_Step : Callbacks.Callback_List; + + -- Called after updating the signals. For value change detection. + Cb_Signals_Updated : Callbacks.Callback_List; + + -- Called at the last known delta cycle of a timestep, before execution + -- of postponed processes. + -- The callback may change signals and therefore generating new delta + -- cycle. + Cb_Last_Known_Delta : Callbacks.Callback_List; + + Cb_End_Of_Time_Step : Callbacks.Callback_List; + end Grt.Hooks; diff --git a/src/grt/grt-main.adb b/src/grt/grt-main.adb index 743e4b306..4b2614aad 100644 --- a/src/grt/grt-main.adb +++ b/src/grt/grt-main.adb @@ -178,10 +178,6 @@ package body Grt.Main is Disp_Stats_Hook (0); end if; - if Status = -2 then - return; - end if; - if Expect_Failure then if Status >= 0 then Expect_Failure := False; diff --git a/src/grt/grt-options.adb b/src/grt/grt-options.adb index a03b6bea3..806d77479 100644 --- a/src/grt/grt-options.adb +++ b/src/grt/grt-options.adb @@ -22,10 +22,12 @@ -- 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 Interfaces; use Interfaces; with Grt.Errors; use Grt.Errors; with Grt.Astdio; with Grt.Hooks; +with Grt.Callbacks; package body Grt.Options is @@ -54,8 +56,7 @@ package body Grt.Options is pragma Export (C, Std_Standard_Time_Hr, "std__standard__time__BT__hr"); pragma Weak_External (Std_Standard_Time_Hr); - procedure Set_Time_Resolution (Res : Character) - is + procedure Set_Time_Resolution (Res : Character) is begin Std_Standard_Time_Hr := 0; case Res is @@ -220,6 +221,16 @@ package body Grt.Options is end if; end To_Lower; + Stop_Time : Std_Time := Std_Time'First; + + procedure Stop_Time_Callback (Arg : System.Address) + is + pragma Unreferenced (Arg); + begin + Break_Simulation := True; + Info ("simulation stopped by --stop-time"); + end Stop_Time_Callback; + procedure Decode_Option (Option : String; Status : out Decode_Option_Status) is @@ -308,7 +319,7 @@ package body Grt.Options is if Flag_String (5) = '-' then Error ("time resolution is ignored"); elsif Flag_String (5) = '?' then - if Stop_Time /= Std_Time'Last then + if Stop_Time /= Std_Time'First then Error ("time resolution must be set " & "before --stop-time"); else @@ -519,5 +530,16 @@ package body Grt.Options is end case; end; end loop; + + if Stop_Time /= Std_Time'First then + declare + use Callbacks; + Stop_Handle : Callback_Handle; + begin + Register_Callback_At + (Hooks.Cb_After_Delay, Stop_Handle, + Stop_Time, Stop_Time_Callback'Access); + end; + end if; end Decode; end Grt.Options; diff --git a/src/grt/grt-options.ads b/src/grt/grt-options.ads index 44a85b6eb..604952e20 100644 --- a/src/grt/grt-options.ads +++ b/src/grt/grt-options.ads @@ -118,10 +118,6 @@ package Grt.Options is -- Handling of assertions from IEEE library. Ieee_Asserts : Assert_Handling := Enable_Asserts; - -- Set by --stop-time=XXX to stop the simulation at or just after XXX. - -- (unit is fs in fact). - Stop_Time : Std_Time := Std_Time'Last; - -- Set by --stop-delta=XXX to stop the simulation after XXX delta cycles. Stop_Delta : Natural := 5000; @@ -132,6 +128,9 @@ package Grt.Options is type Activity_Mode is (Activity_All, Activity_Minimal, Activity_None); Flag_Activity : Activity_Mode := Activity_Minimal; + -- If true, the simulation should be stopped. + Break_Simulation : Boolean; + -- Set by --thread= -- Number of threads used to do the simulation. -- 1 mean no additionnal threads, 0 means as many threads as number of diff --git a/src/grt/grt-processes.adb b/src/grt/grt-processes.adb index 748ab6dd9..feb312337 100644 --- a/src/grt/grt-processes.adb +++ b/src/grt/grt-processes.adb @@ -33,6 +33,7 @@ with Grt.Options; with Grt.Rtis_Addr; use Grt.Rtis_Addr; with Grt.Rtis_Utils; with Grt.Hooks; +with Grt.Callbacks; use Grt.Callbacks; with Grt.Disp_Signals; with Grt.Stats; with Grt.Threads; use Grt.Threads; @@ -316,12 +317,12 @@ package body Grt.Processes is -- List of unused action_list to be recycled. Old_Action_List : Action_List_Acc; - procedure Ghdl_Process_Wait_Add_Sensitivity (Sig : Ghdl_Signal_Ptr) is Proc : constant Process_Acc := Get_Current_Process; El : Action_List_Acc; begin + -- Allocate a structure. if Old_Action_List = null then El := new Action_List (Dynamic => True); else @@ -620,21 +621,23 @@ package body Grt.Processes is -- 1) TIME'HIGH Res := Std_Time'Last; - -- 2) The next time at which a driver becomes active, or - Res := Std_Time'Min (Res, Grt.Signals.Find_Next_Time); + -- 3) The next time at which a process resumes. + Res := Std_Time'Min (Res, Process_First_Timeout); + + -- LRM08 14.7.5.1 Model execution + -- d) The next time at which a registered and enabled vhpiCbAfterDelay + -- [...] callback is to occur. + Res := Std_Time'Min (Res, Get_First_Time (Hooks.Cb_After_Delay)); if Res = Current_Time then return Res; end if; - -- 3) The next time at which a process resumes. - if Process_First_Timeout < Res then - -- No signals to be updated. - Grt.Signals.Flush_Active_List; - - Res := Process_First_Timeout; - end if; + -- 2) The next time at which a driver becomes active, or [...] + Res := Grt.Signals.Find_Next_Time (Res); + -- Note that Find_Next_Time has a side effect: it updates the + -- active_chain. That's the reason why it is the last. return Res; end Compute_Next_Time; @@ -688,16 +691,6 @@ package body Grt.Processes is -- Run resumed processes. -- If POSTPONED is true, resume postponed processes, else resume -- non-posponed processes. - -- Returns one of these values: - -- No process has been run. - Run_None : constant Integer := 1; - -- At least one process was run. - Run_Resumed : constant Integer := 2; - -- Simulation is finished. - Run_Finished : constant Integer := 3; - -- Stop/finish request from user (via std.env). - Run_Stop : constant Integer := -2; - pragma Unreferenced (Run_Stop); Mt_Last : Natural; Mt_Table : Process_Acc_Array_Acc; @@ -736,7 +729,7 @@ package body Grt.Processes is end loop; end Run_Processes_Threads; - function Run_Processes (Postponed : Boolean) return Natural + function Run_Processes (Postponed : Boolean) return Integer is Table : Process_Acc_Array_Acc; Last : Natural; @@ -795,9 +788,13 @@ package body Grt.Processes is end if; end Run_Processes; + -- Updated by Initialization_Phase and Simulation_Cycle to the time of the + -- next cycle. Unchanged in case of delta-cycle. + Next_Time : Std_Time; + procedure Initialization_Phase is - Status : Natural; + Status : Integer; pragma Unreferenced (Status); begin -- Allocate processes arrays. @@ -843,7 +840,10 @@ package body Grt.Processes is -- - The time of the next simulation cycle (which in this case is the -- first simulation cycle), Tn, is calculated according to the rules -- of step f of the simulation cycle, below. - Current_Time := Compute_Next_Time; + Next_Time := Compute_Next_Time; + if Next_Time /= 0 then + Update_Active_Chain; + end if; -- Clear current_delta, will be set by Simulation_Cycle. Current_Delta := 0; @@ -856,7 +856,7 @@ package body Grt.Processes is Tn : Std_Time; Status : Integer; begin - -- LRM93 12.6.4 + -- LRM08 14.7.5.3 Simulation cycle (ex LRM93 12.6.4) -- A simulation cycle consists of the following steps: -- -- a) The current time, Tc is set equal to Tn. Simulation is complete @@ -865,22 +865,53 @@ package body Grt.Processes is -- GHDL: this is done at the last step of the cycle. null; - -- b) Each active explicit signal in the model is updated. (Events - -- may occur on signals as a result). - -- c) Each implicit signal in the model is updated. (Events may occur - -- on signals as a result.) + -- b) The following actions occur in the indicated order: + -- 1) If the current simulation cycle is not a delta cycle, each + -- registered and enabled vhpiCbNextTimeStep and + -- vhpiCbRepNextTimeStep callback is executed [TODO] + if Current_Delta = 0 then + Call_Callbacks (Hooks.Cb_Next_Time_Step); + end if; + + -- 2) Each registered and enabled vhpiCbStartOfNextCycle and + -- vhpiCbRepStartOfNextCycle callback is executed [TODO] + -- 3) Each registered and enabled vhpiCbAfterDelay and + -- vhpiCbRepAfterDelay callback is executed. + if Current_Time = Get_First_Time (Hooks.Cb_After_Delay) then + Call_Time_Callbacks (Hooks.Cb_After_Delay); + if Options.Break_Simulation then + return Run_Stop; + end if; + end if; + + -- c) Each active driver in the model is updated. If a force or deposit + -- was scheduled for any driver, the force or deposit is no longer + -- scheduler for the driver [TODO] + -- d) Each signal on each net in the model that includes active drivers + -- is updated in an order that is consistent with the dependency + -- relaction between signals (see 14.7.4). (Events may occur on + -- signals as a results.) If a force, deposit, or release was + -- scheduled for any signal, the force, deposit, or release is no + -- longer scheduled for the signal. if Options.Flag_Stats then Stats.Start_Update; end if; Update_Signals; + Call_Callbacks (Hooks.Cb_Signals_Updated); if Options.Flag_Stats then Stats.Start_Resume; end if; - -- d) For each process P, if P is currently sensitive to a signal S and - -- if an event has occured on S in this simulation cycle, then P - -- resumes. + -- e) Any action required to give effect to a PSL directive is performed + -- [TODO] + null; + + -- f) The following actions occur in the indicated order: + -- 2) For each process P, if P is currently sensitive to a signal S + -- and if an event has occured on S in this simulation cycle, then + -- P resumes. if Current_Time = Process_First_Timeout then + -- There are processes to awake. Tn := Last_Time; declare Proc : Process_Acc; @@ -921,44 +952,61 @@ package body Grt.Processes is Process_First_Timeout := Tn; end if; - -- e) Each nonpostponed that has resumed in the current simulation cycle - -- is executed until it suspends. + -- 3) For each nonpostponed that has resumed in the current + -- simulation cycle, the following actions occur in the indicated + -- order: + -- - Each registered and enabled vhpiCbResume callback associated + -- with P is executed [TODO] + -- - The processes executes until it suspends. + -- - Each registered and enabled vhpiCbSyspend callback associated + -- with P is executed [TODO] Status := Run_Processes (Postponed => False); - -- f) The time of the next simulation cycle, Tn, is determined by - -- setting it to the earliest of - -- 1) TIME'HIGH - -- 2) The next time at which a driver becomes active, or - -- 3) The next time at which a process resumes. - -- If Tn = Tc, then the next simulation cycle (if any) will be a - -- delta cycle. + -- g) The time of the next simulation cycle, Tn, is calculated according + -- to the rules of 14.7.5.1 if Options.Flag_Stats then Stats.Start_Next_Time; end if; Tn := Compute_Next_Time; - -- g) If the next simulation cycle will be a delta cycle, the remainder - -- of the step is skipped. - -- Otherwise, each postponed process that has resumed but has not - -- been executed since its last resumption is executed until it - -- suspends. Then Tn is recalculated according to the rules of - -- step f. It is an error if the execution of any postponed - -- process causes a delta cycle to occur immediatly after the - -- current simulation cycle. - if Tn = Current_Time then - if Current_Time = Last_Time and then Status = Run_None then - return Run_Finished; - else - Current_Delta := Current_Delta + 1; - return Run_Resumed; + -- h) If the next simulation cycle will be a delta cycle, the remainder + -- of the step is skipped. Otherwise the following actions occur + -- in the indicated order: + -- 1) Each registered and enabled vhpiLastKnownDeltaCycle and + -- vhpiCbRepLastKnownDeltaCycle callback is executed. Tn is + -- recalculated according to the rules of 14.7.5.1 + -- [...] + -- 4) For each postponed process P, if P has resumed but has not been + -- executed since its last resumption, the following actions occur + -- in the indicated order: + -- - Each registered and enabled vhpiCbResume callback associated + -- with P is executed [TODO] + -- - The process executes until it suspends. + -- - Each registered and enabled vhpiCbSuspend callback associated + -- with P is executed [TODO] + -- 5) Tn is recalculated according to the rules of 14.7.5.1 + -- 6) [TODO] + -- 7) If Tn = TIME'HIGH and there are no active drivers, process + -- resumptions, or registered and enabled vhpiCbAfterDelay, + -- vhpiCbRepAfterDelay, vhpiCbTimeOut, or VhpiCbRepTimeOut + -- callbacks to occur at Tn, then each registered and enabled + -- vhpiCbQuiescence is executed. [TODO] + -- Tn is recalculated according to the rules of 14.7.5.1 + -- It is an error if the execution of any postponed process or any + -- callback executed in substeps 3) through 7) of step h) causes a + -- delta cycle to occur immediatly after the current simulation + -- cycle. + if Tn /= Current_Time then + if Has_Callbacks (Hooks.Cb_Last_Known_Delta) then + Call_Callbacks (Hooks.Cb_Last_Known_Delta); + Flush_Active_Chain; + Tn := Compute_Next_Time; end if; - else - Current_Delta := 0; - if Nbr_Postponed_Processes /= 0 then + end if; + if Tn /= Current_Time then + if Last_Postponed_Resume_Process /= 0 then + Flush_Active_Chain; Status := Run_Processes (Postponed => True); - end if; - if Status = Run_Resumed then - Flush_Active_List; if Options.Flag_Stats then Stats.Start_Next_Time; end if; @@ -967,15 +1015,27 @@ package body Grt.Processes is Error ("postponed process causes a delta cycle"); end if; end if; - Current_Time := Tn; + + Call_Callbacks (Hooks.Cb_End_Of_Time_Step); + + Update_Active_Chain; + Next_Time := Tn; + Current_Delta := 0; + return Run_Resumed; + end if; + + if Current_Time = Last_Time and then Status = Run_None then + -- End of time and no process to run. + return Run_Finished; + else + Current_Delta := Current_Delta + 1; return Run_Resumed; end if; end Simulation_Cycle; - function Simulation return Integer + procedure Simulation_Init is use Options; - Status : Integer; begin if Nbr_Threads /= 1 then Threads.Init; @@ -993,20 +1053,29 @@ package body Grt.Processes is Grt.Disp_Signals.Disp_All_Signals; end if; - if Current_Time /= 0 then + if Next_Time /= 0 then -- This is the end of a cycle. This can happen when the time is not -- zero after initialization. - Cycle_Time := 0; Grt.Hooks.Call_Cycle_Hooks; end if; + end Simulation_Init; + function Simulation_Main_Loop return Integer + is + use Options; + Status : Integer; + begin loop - Cycle_Time := Current_Time; + -- Update time. This is the only place where Current_Time is + -- updated. + Current_Time := Next_Time; if Disp_Time then Grt.Disp.Disp_Now; end if; + Status := Simulation_Cycle; - exit when Status < 0; + exit when Status = Run_Stop; + if Trace_Signals then Grt.Disp_Signals.Disp_All_Signals; end if; @@ -1027,14 +1096,15 @@ package body Grt.Processes is Error ("simulation stopped by --stop-delta"); exit; end if; - if Current_Time > Stop_Time then - if Current_Time /= Last_Time then - Info ("simulation stopped by --stop-time"); - end if; - exit; - end if; end loop; + return Status; + end Simulation_Main_Loop; + + procedure Simulation_Finish + is + use Options; + begin if Nbr_Threads /= 1 then Threads.Finish; end if; @@ -1042,6 +1112,17 @@ package body Grt.Processes is Call_Finalizers; Grt.Hooks.Call_Finish_Hooks; + end Simulation_Finish; + + function Simulation return Integer + is + Status : Integer; + begin + Simulation_Init; + + Status := Simulation_Main_Loop; + + Simulation_Finish; return Status; end Simulation; diff --git a/src/grt/grt-processes.ads b/src/grt/grt-processes.ads index ecef800d4..00b057e41 100644 --- a/src/grt/grt-processes.ads +++ b/src/grt/grt-processes.ads @@ -48,9 +48,6 @@ package Grt.Processes is -- Number of non-delta cycles. Nbr_Cycles : Integer; - -- If true, the simulation should be stopped. - Break_Simulation : Boolean; - type Process_Type is private; -- type Process_Acc is access all Process_Type; diff --git a/src/grt/grt-rtis_addr.adb b/src/grt/grt-rtis_addr.adb index 444f1f033..48ab477c7 100644 --- a/src/grt/grt-rtis_addr.adb +++ b/src/grt/grt-rtis_addr.adb @@ -308,15 +308,13 @@ package body Grt.Rtis_Addr is end case; end Get_Base_Type; - function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean - is + function Rti_Complex_Type (Atype : Ghdl_Rti_Access) return Boolean is begin return (Atype.Mode and Ghdl_Rti_Type_Complex_Mask) = Ghdl_Rti_Type_Complex; end Rti_Complex_Type; - function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean - is + function Rti_Anonymous_Type (Atype : Ghdl_Rti_Access) return Boolean is begin return (Atype.Mode and Ghdl_Rti_Type_Anonymous_Mask) = Ghdl_Rti_Type_Anonymous; diff --git a/src/grt/grt-signals.adb b/src/grt/grt-signals.adb index fc97729c7..b86e23466 100644 --- a/src/grt/grt-signals.adb +++ b/src/grt/grt-signals.adb @@ -137,7 +137,7 @@ package body Grt.Signals is function Is_Signal_Guarded (Sig : Ghdl_Signal_Ptr) return Boolean is begin - return Sig.Sig_Kind /= Kind_Signal_No; + return Sig.Flags.Sig_Kind /= Kind_Signal_No; end Is_Signal_Guarded; function To_Address is new Ada.Unchecked_Conversion @@ -211,13 +211,13 @@ package body Grt.Signals is Event => False, Active => False, Has_Active => False, - Sig_Kind => Sig_Kind, - Is_Direct_Active => False, Mode => Mode, Flags => (Propag => Propag_None, + Sig_Kind => Sig_Kind, + Is_Direct_Active => False, Is_Dumped => False, - Cyc_Event => False, + RO_Event => False, Seen => False), Net => No_Signal_Net, @@ -536,7 +536,7 @@ package body Grt.Signals is function Has_Transaction_In_Next_Delta (Sig : Ghdl_Signal_Ptr) return Boolean is begin - if Sig.Is_Direct_Active then + if Sig.Flags.Is_Direct_Active then return True; end if; @@ -563,6 +563,14 @@ package body Grt.Signals is -- This signal is not in the signal table. Signal_End : Ghdl_Signal_Ptr; + -- List of signals that will be active in the next delta cycle. + Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr; + + -- List of implicit signals that will be active in the next cycle. + -- They are put in a different chain (other than ghdl_signal_active_chain), + -- because their handling is different. FIXME: try to merge them ? + Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr; + -- List of signals which have projected waveforms in the future (beyond -- the next delta cycle). Future_List : aliased Ghdl_Signal_Ptr; @@ -812,7 +820,7 @@ package body Grt.Signals is end if; -- Must be always set (as Sign.Link may be set by a regular driver). - Sign.Is_Direct_Active := True; + Sign.Flags.Is_Direct_Active := True; end Ghdl_Signal_Direct_Assign; procedure Ghdl_Signal_Simple_Assign_Error (Sign : Ghdl_Signal_Ptr; @@ -1750,31 +1758,102 @@ package body Grt.Signals is end if; end Ghdl_Signal_Driving_Value_F64; - Ghdl_Implicit_Signal_Active_Chain : Ghdl_Signal_Ptr; + type Force_Value_Kind is (Force_Driving, Force_Effective); + -- To add: Release_Driving, Release_Effective + + type Force_Value (Kind : Force_Value_Kind); + type Force_Value_Acc is access Force_Value; + + type Force_Value (Kind : Force_Value_Kind) is record + Next : Force_Value_Acc; + Sig : Ghdl_Signal_Ptr; + Val : Value_Union; + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Force_Value, Force_Value_Acc); + + -- Chain of forced values for the next cycle. + Force_Value_First : Force_Value_Acc; + Force_Value_Last : Force_Value_Acc; + + procedure Append_Force_Value (F : Force_Value_Acc) is + begin + if Force_Value_First = null then + Force_Value_First := F; + else + Force_Value_Last.Next := F; + end if; + Force_Value_Last := F; + end Append_Force_Value; + + procedure Ghdl_Signal_Force_Driving_B1 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_B1) is + begin + Append_Force_Value (new Force_Value'(Kind => Force_Driving, + Next => null, + Sig => Sig, + Val => (Mode => Mode_B1, + B1 => Val))); + end Ghdl_Signal_Force_Driving_B1; + + procedure Ghdl_Signal_Force_Effective_B1 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_B1) is + begin + Append_Force_Value (new Force_Value'(Kind => Force_Effective, + Next => null, + Sig => Sig, + Val => (Mode => Mode_B1, + B1 => Val))); + end Ghdl_Signal_Force_Effective_B1; + + procedure Ghdl_Signal_Force_Driving_E8 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_E8) is + begin + Append_Force_Value (new Force_Value'(Kind => Force_Driving, + Next => null, + Sig => Sig, + Val => (Mode => Mode_E8, + E8 => Val))); + end Ghdl_Signal_Force_Driving_E8; + + procedure Ghdl_Signal_Force_Effective_E8 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_E8) is + begin + Append_Force_Value (new Force_Value'(Kind => Force_Effective, + Next => null, + Sig => Sig, + Val => (Mode => Mode_E8, + E8 => Val))); + end Ghdl_Signal_Force_Effective_E8; + + -- Updated by Find_Next_Time to the list of signal that would be active + -- at the time returned (if not current_time). + Next_Signal_Active_Chain : Ghdl_Signal_Ptr; - procedure Flush_Active_List + -- Remove all (but Signal_End) signals in the active chain. + procedure Flush_Active_Chain is Sig : Ghdl_Signal_Ptr; Next_Sig : Ghdl_Signal_Ptr; begin -- Free active_chain. - Sig := Ghdl_Signal_Active_Chain; + Sig := Next_Signal_Active_Chain; loop Next_Sig := Sig.Link; exit when Next_Sig = null; Sig.Link := null; Sig := Next_Sig; end loop; - Ghdl_Signal_Active_Chain := Sig; - end Flush_Active_List; + Next_Signal_Active_Chain := Sig; + end Flush_Active_Chain; - function Find_Next_Time return Std_Time + function Find_Next_Time (Tn : Std_Time) return Std_Time is Res : Std_Time; Sig : Ghdl_Signal_Ptr; - procedure Check_Transaction (Trans : Transaction_Acc) - is + procedure Check_Transaction (Trans : Transaction_Acc) is begin if Trans = null or else Trans.Kind = Trans_Direct then -- Activity of direct drivers is done through link. @@ -1782,14 +1861,15 @@ package body Grt.Signals is end if; if Trans.Time = Res and Sig.Link = null then - Sig.Link := Ghdl_Signal_Active_Chain; - Ghdl_Signal_Active_Chain := Sig; + -- Put to active list. + Sig.Link := Next_Signal_Active_Chain; + Next_Signal_Active_Chain := Sig; elsif Trans.Time < Res then - Flush_Active_List; + Flush_Active_Chain; -- Put sig on the list. - Sig.Link := Ghdl_Signal_Active_Chain; - Ghdl_Signal_Active_Chain := Sig; + Sig.Link := Next_Signal_Active_Chain; + Next_Signal_Active_Chain := Sig; Res := Trans.Time; end if; @@ -1799,16 +1879,20 @@ package body Grt.Signals is end if; end Check_Transaction; begin + pragma Assert (Tn >= Current_Time); -- If there is signals in the active list, then next cycle is a delta -- cycle, so next time is current_time. if Ghdl_Signal_Active_Chain.Link /= null then return Current_Time; end if; + if Force_Value_First /= null then + return Current_Time; + end if; if Ghdl_Implicit_Signal_Active_Chain.Link /= null then return Current_Time; end if; - Res := Std_Time'Last; + Res := Tn; Sig := Future_List; while Sig.Flink /= null loop case Sig.S.Mode_Sig is @@ -1828,6 +1912,13 @@ package body Grt.Signals is return Res; end Find_Next_Time; + procedure Update_Active_Chain is + begin + pragma Assert (Ghdl_Signal_Active_Chain.Link = null); + Ghdl_Signal_Active_Chain := Next_Signal_Active_Chain; + Next_Signal_Active_Chain := Signal_End; + end Update_Active_Chain; + -- function Get_Nbr_Non_Null_Source (Sig : Ghdl_Signal_Ptr) -- return Natural -- is @@ -1889,7 +1980,7 @@ package body Grt.Signals is -- if no driving sources and register, exit. if Length = 0 and then Sig.Nbr_Ports = 0 - and then Sig.Sig_Kind = Kind_Signal_Register + and then Sig.Flags.Sig_Kind = Kind_Signal_Register then return; end if; @@ -2641,7 +2732,7 @@ package body Grt.Signals is (Resolv.Resolv_Proc = To_Resolver_Acc (Ieee_Std_Logic_1164_Resolved_Resolv_Ptr)) and then Sig.S.Nbr_Drivers + Sig.Nbr_Ports <= 1 - and then Sig.Sig_Kind = Kind_Signal_No + and then Sig.Flags.Sig_Kind = Kind_Signal_No then -- Optimization: remove resolver if there is at most one -- source. @@ -2831,7 +2922,7 @@ package body Grt.Signals is Sig.Value := Val; Sig.Event := True; Sig.Last_Event := Current_Time; - Sig.Flags.Cyc_Event := True; + Sig.Flags.RO_Event := True; El := Sig.Event_List; while El /= null loop @@ -3106,6 +3197,35 @@ package body Grt.Signals is -- 1) Reset active flag. Reset_Active_Flag; + -- Forced signals. + if Force_Value_First /= null then + declare + Fv : Force_Value_Acc; + Next_Fv : Force_Value_Acc; + begin + Fv := Force_Value_First; + while Fv /= null loop + Sig := Fv.Sig; + -- FIXME: Implement the full semantic of force: really force, + -- only set driving/effective value, release... + case Fv.Kind is + when Force_Driving => + Mark_Active (Sig); + Sig.Driving_Value := Fv.Val; + Set_Effective_Value (Sig, Sig.Driving_Value); + when Force_Effective => + Mark_Active (Sig); + Set_Effective_Value (Sig, Fv.Val); + end case; + Next_Fv := Fv.Next; + Free (Fv); + Fv := Next_Fv; + end loop; + Force_Value_First := null; + Force_Value_Last := null; + end; + end if; + -- For each active signals Sig := Ghdl_Signal_Active_Chain; Ghdl_Signal_Active_Chain := Signal_End; @@ -3135,7 +3255,7 @@ package body Grt.Signals is when Net_One_Direct => Mark_Active (Sig); - Sig.Is_Direct_Active := False; + Sig.Flags.Is_Direct_Active := False; Trans := Sig.S.Drivers (0).Last_Trans; Assign (Sig.Driving_Value, Trans.Val_Ptr.all, Sig.Mode); @@ -3145,7 +3265,7 @@ package body Grt.Signals is when Net_One_Resolved => -- This signal is active. Mark_Active (Sig); - Sig.Is_Direct_Active := False; + Sig.Flags.Is_Direct_Active := False; for J in 1 .. Sig.S.Nbr_Drivers loop Trans := Sig.S.Drivers (J - 1).First_Trans.Next; @@ -3166,7 +3286,7 @@ package body Grt.Signals is Internal_Error ("update_signals: no_signal_net"); when others => - Sig.Is_Direct_Active := False; + Sig.Flags.Is_Direct_Active := False; if not Propagation.Table (Sig.Net).Updated then Propagation.Table (Sig.Net).Updated := True; Run_Propagation (Sig.Net + 1); @@ -3379,13 +3499,13 @@ package body Grt.Signals is Event => False, Active => False, Has_Active => False, - Is_Direct_Active => False, - Sig_Kind => Kind_Signal_No, Mode => Mode_B1, Flags => (Propag => Propag_None, + Sig_Kind => Kind_Signal_No, + Is_Direct_Active => False, Is_Dumped => False, - Cyc_Event => False, + RO_Event => False, Seen => False), Net => No_Signal_Net, @@ -3404,6 +3524,7 @@ package body Grt.Signals is Ghdl_Signal_Active_Chain := Signal_End; Ghdl_Implicit_Signal_Active_Chain := Signal_End; Future_List := Signal_End; + Next_Signal_Active_Chain := Signal_End; Boolean_Signal_Rti.Obj_Type := Std_Standard_Boolean_RTI_Ptr; Bit_Signal_Rti.Obj_Type := Std_Standard_Bit_RTI_Ptr; diff --git a/src/grt/grt-signals.ads b/src/grt/grt-signals.ads index 8461e5e25..36ef69263 100644 --- a/src/grt/grt-signals.ads +++ b/src/grt/grt-signals.ads @@ -227,9 +227,6 @@ package Grt.Signals is Net_One_Direct : constant Signal_Net_Type := -2; Net_One_Resolved : constant Signal_Net_Type := -3; - -- Flush the list of active signals. - procedure Flush_Active_List; - type Ghdl_Signal_Data (Mode_Sig : Mode_Signal_Type := Mode_Signal) is record case Mode_Sig is @@ -273,12 +270,18 @@ package Grt.Signals is -- Status of the ordering. Propag : Propag_Order_Flag; + -- Kind of the signal (none, bus or register). + Sig_Kind : Kind_Signal_Type; + + -- If set, the signal has an active direct driver. + Is_Direct_Active : Boolean; + -- If set, the signal is dumped in a GHW file. Is_Dumped : Boolean; -- Set when an event occured. -- Only reset by GHW file dumper. - Cyc_Event : Boolean; + RO_Event : Boolean; -- Set if the signal has already been visited. When outside of the -- algorithm that use it, it must be cleared. @@ -302,12 +305,6 @@ package Grt.Signals is -- Internal fields. -- NOTE: keep above fields (components) in sync with translation. - -- If set, the signal has an active direct driver. - Is_Direct_Active : Boolean; - - -- Kind of the signal (none, bus or register). - Sig_Kind : Kind_Signal_Type; - -- Values mode of this signal. Mode : Mode_Type; @@ -354,9 +351,6 @@ package Grt.Signals is Table_Low_Bound => 0, Table_Initial => 128); - -- Return the next time at which a driver becomes active. - function Find_Next_Time return Std_Time; - -- Elementary propagation computation. -- See LRM 12.6.2 and 12.6.3 type Propagation_Kind_Type is @@ -481,7 +475,22 @@ package Grt.Signals is -- Initialize all signals. procedure Init_Signals; - -- Update signals. + -- Return the next time at which a driver becomes active. + -- SIDE EFFECT: this function updates the next_signal_active_chain. + -- Note: the next_signal_active_chain must be empty before running + -- processes as they assume that if signals are on a list, they are on the + -- ghdl_signal_active_chain (and not on next_signal_active_chain). Use one + -- of Update_Active_Chain or Flush_Active_Chain for that effect. + function Find_Next_Time (Tn : Std_Time) return Std_Time; + + -- To be called after Find_Next_Time to update the chain of active signals, + -- only if the next cycle is not a delta cycle. + procedure Update_Active_Chain; + + -- Empty the next_signal_active_chain. + procedure Flush_Active_Chain; + + -- Update all active signals. procedure Update_Signals; -- Set the effective value of signal SIG to VAL. @@ -575,6 +584,10 @@ package Grt.Signals is After : Std_Time); function Ghdl_Signal_Driving_Value_B1 (Sig : Ghdl_Signal_Ptr) return Ghdl_B1; + procedure Ghdl_Signal_Force_Driving_B1 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_B1); + procedure Ghdl_Signal_Force_Effective_B1 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_B1); function Ghdl_Create_Signal_E8 (Init_Val : Ghdl_E8; Resolv_Func : Resolver_Acc; @@ -593,6 +606,10 @@ package Grt.Signals is After : Std_Time); function Ghdl_Signal_Driving_Value_E8 (Sig : Ghdl_Signal_Ptr) return Ghdl_E8; + procedure Ghdl_Signal_Force_Driving_E8 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_E8); + procedure Ghdl_Signal_Force_Effective_E8 (Sig : Ghdl_Signal_Ptr; + Val : Ghdl_E8); function Ghdl_Create_Signal_E32 (Init_Val : Ghdl_E32; Resolv_Func : Resolver_Acc; @@ -760,8 +777,6 @@ package Grt.Signals is (Sig : Ghdl_Signal_Ptr; Index : Ghdl_Index_Type) return Ghdl_Value_Ptr; - Ghdl_Signal_Active_Chain : aliased Ghdl_Signal_Ptr; - -- Statistics. Nbr_Active : Ghdl_I32; Nbr_Events: Ghdl_I32; @@ -924,8 +939,4 @@ private "__ghdl_signal_read_port"); pragma Export (C, Ghdl_Signal_Read_Driver, "__ghdl_signal_read_driver"); - - pragma Export (C, Ghdl_Signal_Active_Chain, - "__ghdl_signal_active_chain"); - end Grt.Signals; diff --git a/src/grt/grt-std_logic_1164.ads b/src/grt/grt-std_logic_1164.ads index 4d1569553..b3b5d293c 100644 --- a/src/grt/grt-std_logic_1164.ads +++ b/src/grt/grt-std_logic_1164.ads @@ -26,7 +26,7 @@ with Grt.Types; use Grt.Types; package Grt.Std_Logic_1164 is - type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W','L', 'H', '-'); + type Std_Ulogic is ('U', 'X', '0', '1', 'Z', 'W', 'L', 'H', '-'); type Stdlogic_Table_2d is array (Std_Ulogic, Std_Ulogic) of Std_Ulogic; type Stdlogic_Table_1d is array (Std_Ulogic) of Std_Ulogic; diff --git a/src/grt/grt-types.ads b/src/grt/grt-types.ads index c0b3c3be0..71987119b 100644 --- a/src/grt/grt-types.ads +++ b/src/grt/grt-types.ads @@ -313,9 +313,6 @@ package Grt.Types is -- The NOW value. Current_Time : Std_Time; - -- Copy of Current_Time before updating it. - -- To be used by hooks. - Cycle_Time : Std_Time; -- The current delta cycle number. Current_Delta : Integer; private diff --git a/src/grt/grt-vcd.adb b/src/grt/grt-vcd.adb index 13da7f91a..d29ae2352 100644 --- a/src/grt/grt-vcd.adb +++ b/src/grt/grt-vcd.adb @@ -767,13 +767,42 @@ package body Grt.Vcd is return False; end Verilog_Wire_Changed; + function Verilog_Wire_Event (Info : Verilog_Wire_Info) return Boolean + is + Len : Ghdl_Index_Type; + begin + if Info.Irange = null then + Len := 1; + else + Len := Info.Irange.I32.Len; + end if; + + case Info.Kind is + when Vcd_Bit + | Vcd_Bool + | Vcd_Stdlogic + | Vcd_Bitvector + | Vcd_Stdlogic_Vector + | Vcd_Integer32 + | Vcd_Float64 => + for J in 0 .. Len - 1 loop + if Info.Sigs (J).Event then + return True; + end if; + end loop; + when Vcd_Bad => + null; + end case; + return False; + end Verilog_Wire_Event; + procedure Vcd_Put_Time is Str : String (1 .. 21); First : Natural; begin Vcd_Putc ('#'); - Vstrings.To_String (Str, First, Ghdl_I64 (Cycle_Time)); + Vstrings.To_String (Str, First, Ghdl_I64 (Current_Time)); Vcd_Put (Str (First .. Str'Last)); Vcd_Newline; end Vcd_Put_Time; @@ -809,7 +838,7 @@ package body Grt.Vcd is begin -- Disp values. Vcd_Put_Time; - if Cycle_Time = 0 then + if Current_Time = 0 then -- Disp all values. for I in Vcd_Table.First .. Vcd_Table.Last loop Vcd_Put_Var (I); @@ -817,7 +846,7 @@ package body Grt.Vcd is else -- Disp only values changed. for I in Vcd_Table.First .. Vcd_Table.Last loop - if Verilog_Wire_Changed (Vcd_Table.Table (I), Cycle_Time) then + if Verilog_Wire_Changed (Vcd_Table.Table (I), Current_Time) then Vcd_Put_Var (I); end if; end loop; diff --git a/src/grt/grt-vcd.ads b/src/grt/grt-vcd.ads index a3561f534..bc7917cba 100644 --- a/src/grt/grt-vcd.ads +++ b/src/grt/grt-vcd.ads @@ -63,9 +63,13 @@ package Grt.Vcd is function Get_Wire_Length (Info : Verilog_Wire_Info) return Ghdl_Index_Type; -- Return TRUE if last change time of the wire described by INFO is LAST. + -- Used by vcd to know if a signal has changed and should be dumped. function Verilog_Wire_Changed (Info : Verilog_Wire_Info; Last : Std_Time) return Boolean; + -- Return TRUE if there is an event on the wire, for the current cycle. + function Verilog_Wire_Event (Info : Verilog_Wire_Info) return Boolean; + procedure Register; end Grt.Vcd; diff --git a/src/grt/grt-vpi.adb b/src/grt/grt-vpi.adb index bc594e44b..eedb8460c 100644 --- a/src/grt/grt-vpi.adb +++ b/src/grt/grt-vpi.adb @@ -44,13 +44,14 @@ 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.Table; 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; -pragma Elaborate_All (Grt.Table); +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. @@ -60,7 +61,11 @@ package body Grt.Vpi is --errAnyString: constant String := "grt-vcd.adb: any string" & NUL; --errNoString: constant String := "grt-vcd.adb: no string" & NUL; - type Vpi_Index_Type is new Integer; + 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 * * * * * * * * * * * * * * * * * * * * * * * * * * @@ -121,6 +126,26 @@ package body Grt.Vpi is -- 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 * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------- @@ -135,7 +160,9 @@ package body Grt.Vpi is Rel : VhpiOneToManyT; Error : AvhpiErrorT; begin - --dbgPut_Line ("vpi_iterate"); + Vpi_Trace ("vpi_iterate"); + + Reset_Error; case aType is when vpiNet => @@ -190,9 +217,10 @@ package body Grt.Vpi is -- end case; -- end ii_vpi_get_type; - function vpi_get (Property: integer; Ref: vpiHandle) return Integer - is + function vpi_get (Property: integer; Ref: vpiHandle) return Integer is begin + Vpi_Trace ("vpi_get"); + case Property is when vpiType=> return Ref.mType; @@ -204,6 +232,47 @@ package body Grt.Vpi is 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 @@ -214,8 +283,10 @@ package body Grt.Vpi is Res : VhpiHandleT; Error : AvhpiErrorT; R : vpiHandle; + Kind, Expected_Kind : Integer; begin - --dbgPut_Line ("vpi_scan"); + Vpi_Trace ("vpi_scan"); + if Iter = null then return null; end if; @@ -236,41 +307,24 @@ package body Grt.Vpi is 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; - case Vhpi_Get_Kind (Res) is - when VhpiEntityDeclK - | VhpiArchBodyK - | VhpiBlockStmtK - | VhpiIfGenerateK - | VhpiForGenerateK - | VhpiCompInstStmtK => - case Iter.mType is - when vpiInternalScope - | vpiModule => - return new struct_vpiHandle'(mType => vpiModule, - Ref => Res); - when others => - null; - end case; - when VhpiPortDeclK - | VhpiSigDeclK => - if Iter.mType = vpiNet then - declare - Info : Verilog_Wire_Info; - begin - Get_Verilog_Wire (Res, Info); - if Info.Kind /= Vcd_Bad then - return new struct_vpiHandle'(mType => vpiNet, - Ref => Res); - end if; - end; - end if; - when others => - null; - end case; + 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; @@ -285,7 +339,7 @@ package body Grt.Vpi is Prop : VhpiStrPropertyT; Len : Natural; begin - --dbgPut_Line ("vpiGetStr"); + Vpi_Trace ("vpi_get_str"); if Ref = null then return null; @@ -323,7 +377,7 @@ package body Grt.Vpi is is Res : vpiHandle; begin - --dbgPut_Line ("vpi_handle"); + Vpi_Trace ("vpi_handle"); if Ref = null then return null; @@ -457,9 +511,10 @@ package body Grt.Vpi is 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 + 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: @@ -517,89 +572,156 @@ package body Grt.Vpi is -- see IEEE 1364-2001, chapter 27.14, page 675 -- FIXME - procedure ii_vpi_put_value_bin_str_B1 (SigPtr : Ghdl_Signal_Ptr; - Value : Character) - is - Tempval : Value_Union; + 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 - -- use the Set_Effective_Value procedure to update the signal - case Value is - when '0' => - Tempval.B1 := false; - when '1' => - Tempval.B1 := true; - when others => - dbgPut_Line("ii_vpi_put_value_bin_str_B1: " - & "wrong character - signal wont be set"); - return; - end case; - SigPtr.Driving_Value := Tempval; - Set_Effective_Value (SigPtr, Tempval); - end ii_vpi_put_value_bin_str_B1; - - procedure ii_vpi_put_value_bin_str_E8 (SigPtr : Ghdl_Signal_Ptr; - Value : Character) - is - Tempval : Value_Union; - begin - case Value is - when 'U' => - Tempval.E8 := 0; - when 'X' => - Tempval.E8 := 1; - when '0' => - Tempval.E8 := 2; - when '1' => - Tempval.E8 := 3; - when 'Z' => - Tempval.E8 := 4; - when 'W' => - Tempval.E8 := 5; - when 'L' => - Tempval.E8 := 6; - when 'H' => - Tempval.E8 := 7; - when '-' => - Tempval.E8 := 8; - when others => - dbgPut_Line("ii_vpi_put_value_bin_str_B8: " - & "wrong character - signal wont be set"); + 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; - SigPtr.Driving_Value := Tempval; - Set_Effective_Value (SigPtr, Tempval); - end ii_vpi_put_value_bin_str_E8; + 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(Obj : VhpiHandleT; - ValueStr : Ghdl_C_String) + 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(Obj) is + case Vhpi_Get_Kind (aObj.Ref) is when VhpiPortDeclK | VhpiSigDeclK => null; when others => - return; + return null; end case; -- The following code segment was copied from the -- ii_vpi_get_value function. -- Get verilog compat info. - Get_Verilog_Wire (Obj, Info); + Get_Verilog_Wire (aObj.Ref, Info); if Info.Kind = Vcd_Bad then - return; + 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. @@ -613,63 +735,13 @@ package body Grt.Vpi is -- call (from grt-signals) -- Set_Effective_Value(sig_ptr, conv_value); - - -- Took the skeleton from ii_vpi_get_value function - -- This point of the function must convert the string value to the - -- native ghdl format. - case Info.Kind is - when Vcd_Bad => - return; - when Vcd_Bit - | Vcd_Bool - | Vcd_Bitvector => - for J in 0 .. Len - 1 loop - ii_vpi_put_value_bin_str_B1 - (Info.Sigs (J), ValueStr (Integer (J + 1))); - end loop; - when Vcd_Stdlogic - | Vcd_Stdlogic_Vector => - for J in 0 .. Len - 1 loop - ii_vpi_put_value_bin_str_E8 - (Info.Sigs (J), ValueStr (Integer (J + 1))); - end loop; - when Vcd_Integer32 - | Vcd_Float64 => - null; - end case; - - -- Always return null, because this simulation kernel cannot send - -- a handle to the event back. - return; - 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); - begin - -- 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. - -- 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(aObj.Ref, aValue.Str); + 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"); @@ -680,7 +752,9 @@ package body Grt.Vpi is when vpiScalarVal => dbgPut_Line ("vpi_put_value: vpiNet, vpiScalarVal"); when vpiIntVal => - dbgPut_Line ("vpi_put_value: 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 => @@ -703,71 +777,163 @@ package body Grt.Vpi is ------------------------------------------------------------------------ -- void vpi_get_time(vpiHandle obj, s_vpi_time*t); -- see IEEE 1364-2001, page xxx - Sim_Time : Std_Time; procedure vpi_get_time (Obj: vpiHandle; Time: p_vpi_time) is - pragma Unreferenced (Obj); + function To_Unsigned_64 is new Ada.Unchecked_Conversion + (Std_Time, Unsigned_64); + V : Unsigned_64; begin - --dbgPut_Line ("vpi_get_time"); - Time.mType := vpiSimTime; - Time.mHigh := 0; - Time.mLow := Integer (Sim_Time / 1000000); + 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; ------------------------------------------------------------------------ - -- vpiHandle vpi_register_cb(p_cb_data data) - g_cbEndOfCompile : p_cb_data; - g_cbEndOfSimulation: p_cb_data; - --g_cbValueChange: s_cb_data; - g_cbReadOnlySync: p_cb_data; - type Vpi_Var_Type is record - Info : Verilog_Wire_Info; - Cb : s_cb_data; + type Callback_List is record + First, Last : vpiHandle; end record; - package Vpi_Table is new Grt.Table - (Table_Component_Type => Vpi_Var_Type, - Table_Index_Type => Vpi_Index_Type, - Table_Low_Bound => 0, - Table_Initial => 32); + 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 : p_cb_data := null; + Res : vpiHandle; + T : Std_Time; begin - --dbgPut_Line ("vpi_register_cb"); + Vpi_Trace ("vpi_register_cb"); + + Res := new struct_vpiHandle (vpiCallback); + Res.Cb := Data.all; + case Data.Reason is when cbEndOfCompile => - Res := new s_cb_data'(Data.all); - g_cbEndOfCompile := Res; - Sim_Time:= 0; + Append_Callback (g_cbEndOfCompile, Res); + when cbStartOfSimulation => + Append_Callback (g_cbStartOfSimulation, Res); when cbEndOfSimulation => - Res := new s_cb_data'(Data.all); - g_cbEndOfSimulation := Res; + Append_Callback (g_cbEndOfSimulation, Res); when cbValueChange => - declare - N : Vpi_Index_Type; - begin - --g_cbValueChange:= aData.all; - Vpi_Table.Increment_Last; - N := Vpi_Table.Last; - Vpi_Table.Table (N).Cb := Data.all; - Get_Verilog_Wire (Data.Obj.Ref, Vpi_Table.Table (N).Info); - end; - when cbReadOnlySynch=> - Res := new s_cb_data'(Data.all); - g_cbReadOnlySync := Res; - when others=> - dbgPut_Line ("vpi_register_cb: unknwon reason"); + 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; - if Res /= null then - return new struct_vpiHandle'(mType => vpiCallback, - Cb => Res); - else - return null; - end if; + return Res; end vpi_register_cb; ------------------------------------------------------------------------------- @@ -779,20 +945,24 @@ package body Grt.Vpi is is pragma Unreferenced (aRef); begin - return 0; + return 1; end vpi_free_object; -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) - function vpi_get_vlog_info (aVlog_info_p: System.Address) return integer - is - pragma Unreferenced (aVlog_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 + function vpi_handle_by_index (aRef: vpiHandle; aIndex: integer) + return vpiHandle is pragma Unreferenced (aRef); pragma Unreferenced (aIndex); @@ -800,6 +970,118 @@ package body Grt.Vpi is 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 @@ -829,15 +1111,28 @@ package body Grt.Vpi is is pragma Unreferenced (aSs); begin - null; + Vpi_Trace ("vpi_register_systf"); end vpi_register_systf; -- int vpi_remove_cb(vpiHandle ref) function vpi_remove_cb (Ref : vpiHandle) return Integer is - pragma Unreferenced (Ref); + Ref_Copy : vpiHandle; begin - return 0; + 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) @@ -856,7 +1151,54 @@ package body Grt.Vpi is -- vpi_mcd_fgetc -- vpi_sim_vcontrol -- vpi_chk_error - -- pi_handle_by_name + -- 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 * * * * * * * * * * * * * * * * * * * * * * * @@ -880,6 +1222,9 @@ package body Grt.Vpi is 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; @@ -898,16 +1243,9 @@ package body Grt.Vpi is function LoadVpiModule (Filename: Address) return Integer; pragma Import (C, LoadVpiModule, "loadVpiModule"); - procedure Vpi_Init is begin - Sim_Time:= 0; - - --g_cbEndOfCompile.mCb_rtn:= null; - --g_cbEndOfSimulation.mCb_rtn:= null; - --g_cbValueChange.mCb_rtn:= null; - if Vpi_Filename /= null then if LoadVpiModule (Vpi_Filename.all'Address) /= 0 then Error ("cannot load VPI module"); @@ -915,8 +1253,6 @@ package body Grt.Vpi is end if; end Vpi_Init; - procedure Vpi_Cycle; - ------------------------------------------------------------------------ -- Called after elaboration. procedure Vpi_Start @@ -929,37 +1265,10 @@ package body Grt.Vpi is end if; Grt.Rtis_Types.Search_Types_RTI; - Register_Cycle_Hook (Vpi_Cycle'Access); - if g_cbEndOfCompile /= null then - Res := g_cbEndOfCompile.Cb_Rtn.all (g_cbEndOfCompile); - end if; + Execute_Callback_List (g_cbEndOfCompile); + Execute_Callback_List (g_cbStartOfSimulation); end Vpi_Start; - ------------------------------------------------------------------------ - -- Called before each non delta cycle. - procedure Vpi_Cycle - is - Res : Integer; - pragma Unreferenced (Res); - begin - if g_cbReadOnlySync /= null - and then g_cbReadOnlySync.Time.mLow < Integer (Sim_Time / 1_000_000) - then - Res := g_cbReadOnlySync.Cb_Rtn.all (g_cbReadOnlySync); - end if; - - for I in Vpi_Table.First .. Vpi_Table.Last loop - if Verilog_Wire_Changed (Vpi_Table.Table (I).Info, Sim_Time) then - Res := Vpi_Table.Table (I).Cb.Cb_Rtn.all - (To_p_cb_data (Vpi_Table.Table (I).Cb'Address)); - end if; - end loop; - - if Current_Time /= Std_Time'last then - Sim_Time:= Current_Time; - end if; - end Vpi_Cycle; - ------------------------------------------------------------------------ -- Called at the end of the simulation. procedure Vpi_End @@ -967,9 +1276,7 @@ package body Grt.Vpi is Res : Integer; pragma Unreferenced (Res); begin - if g_cbEndOfSimulation /= null then - Res := g_cbEndOfSimulation.Cb_Rtn.all (g_cbEndOfSimulation); - end if; + Execute_Callback_List (g_cbEndOfSimulation); end Vpi_End; Vpi_Hooks : aliased constant Hooks_Type := diff --git a/src/grt/grt-vpi.ads b/src/grt/grt-vpi.ads index 86fb07374..ddfc7cf99 100644 --- a/src/grt/grt-vpi.ads +++ b/src/grt/grt-vpi.ads @@ -21,9 +21,12 @@ -- Icarus Verilog Interactive (IVI) simulator GUI with System; use System; +with Interfaces; use Interfaces; with Ada.Unchecked_Conversion; with Grt.Types; use Grt.Types; with Grt.Avhpi; use Grt.Avhpi; +with Grt.Vcd; +with Grt.Callbacks; package Grt.Vpi is @@ -42,6 +45,10 @@ package Grt.Vpi is vpiLeftRange: constant integer := 79; vpiRightRange: constant integer := 83; + vpiStop : constant := 66; + vpiFinish : constant := 67; + vpiReset : constant := 68; + -- Additionnal constants. vpiCallback : constant Integer := 200; @@ -64,12 +71,28 @@ package Grt.Vpi is vpiSimTime: constant integer := 2; -- codes for the reason tag of cb_data structure - cbValueChange: constant integer:= 1; - cbReadOnlySynch: constant integer:= 7; - cbEndOfCompile: constant integer:= 10; - cbEndOfSimulation:constant integer:= 12; - - type struct_vpiHandle (mType : Integer := vpiUndefined); + cbValueChange : constant := 1; + cbReadWriteSynch : constant := 6; + cbReadOnlySynch : constant := 7; + cbNextSimTime : constant := 8; + cbAfterDelay : constant := 9; + cbEndOfCompile : constant := 10; + cbStartOfSimulation : constant := 11; + cbEndOfSimulation : constant := 12; + + -- Error types. + vpiCompile : constant := 1; + vpiPLI : constant := 2; + vpiRun : constant := 3; + + -- Error severity levels. + vpiNotive : constant := 1; + vpiWarning : constant := 2; + vpiError : constant := 3; + vpiSystem : constant := 4; + vpiInternal : constant := 5; + + type struct_vpiHandle (<>) is private; type vpiHandle is access struct_vpiHandle; -- typedef struct t_vpi_time { @@ -80,10 +103,11 @@ package Grt.Vpi is -- } s_vpi_time, *p_vpi_time; type s_vpi_time is record mType : Integer; - mHigh : Integer; -- this should be unsigned - mLow : Integer; -- this should be unsigned - mReal : Float; -- this should be double + mHigh : Unsigned_32; + mLow : Unsigned_32; + mReal : Long_Float; end record; + pragma Convention (C, s_vpi_time); type p_vpi_time is access s_vpi_time; -- typedef struct t_vpi_value @@ -118,7 +142,8 @@ package Grt.Vpi is when others => null; end case; - end record; + end record; + -- No use of convention C, as there is no direct equivalent in the norm. type p_vpi_value is access s_vpi_value; --typedef struct t_cb_data { @@ -128,11 +153,12 @@ package Grt.Vpi is -- p_vpi_time time; -- p_vpi_value value; -- int index; - -- char*user_data; + -- char *user_data; --} s_cb_data, *p_cb_data; type s_cb_data; type p_cb_data is access all s_cb_data; + pragma Convention (C, p_cb_data); function To_p_cb_data is new Ada.Unchecked_Conversion (Source => Address, Target => p_cb_data); @@ -148,15 +174,7 @@ package Grt.Vpi is Index : Integer; User_Data : Address; end record; - - type struct_vpiHandle (mType : Integer := vpiUndefined) is record - case mType is - when vpiCallback => - Cb : p_cb_data; - when others => - Ref : VhpiHandleT; - end case; - end record; + pragma Convention (C, s_cb_data); -- vpiHandle vpi_iterate(int type, vpiHandle ref) function vpi_iterate (aType : Integer; Ref : vpiHandle) return vpiHandle; @@ -200,15 +218,31 @@ package Grt.Vpi is function vpi_free_object(aRef: vpiHandle) return integer; pragma Export (C, vpi_free_object, "vpi_free_object"); + type s_vpi_vlog_info is record + Argc : Integer; + Argv : System.Address; + Product : Ghdl_C_String; + Version : Ghdl_C_String; + end record; + pragma Convention (C, s_vpi_vlog_info); + + type p_vpi_vlog_info is access all s_vpi_vlog_info; + pragma Convention (C, p_vpi_vlog_info); + -- int vpi_get_vlog_info(p_vpi_vlog_info vlog_info_p) - function vpi_get_vlog_info(aVlog_info_p: System.Address) return integer; + function vpi_get_vlog_info(info : p_vpi_vlog_info) return integer; pragma Export (C, vpi_get_vlog_info, "vpi_get_vlog_info"); + -- vpiHandle vpi_handle_by_index(vpiHandle ref, int index) function vpi_handle_by_index(aRef: vpiHandle; aIndex: integer) return vpiHandle; pragma Export (C, vpi_handle_by_index, "vpi_handle_by_index"); + function vpi_handle_by_name(Name : Ghdl_C_String; Scope : vpiHandle) + return vpiHandle; + pragma Export (C, vpi_handle_by_name, "vpi_handle_by_name"); + -- unsigned int vpi_mcd_close(unsigned int mcd) function vpi_mcd_close (Mcd : Integer) return Integer; pragma Export (C, vpi_mcd_close, "vpi_mcd_close"); @@ -242,11 +276,49 @@ package Grt.Vpi is procedure vpi_vprintf (Fmt: Address; Ap: Address); pragma Export (C, vpi_vprintf, "vpi_vprintf"); + -- typedef struct t_vpi_error_info + -- { + -- int32_t state; + -- int32_t level; + -- char *message; + -- char *product; + -- char *code; + -- char *file; + -- int32_t line; + -- } s_vpi_error_info, *p_vpi_error_info; + type s_vpi_error_info is record + State : Integer; + Level : Integer; + Message : Ghdl_C_String; + Product : Ghdl_C_String; + Code : Ghdl_C_String; + File : Ghdl_C_String; + Line : Integer; + end record; + type p_vpi_error_info is access all s_vpi_error_info; + + function vpi_chk_error (Info : p_vpi_error_info) return Integer; + pragma Export (C, vpi_chk_error); + + function vpi_control (Op : Integer; Status : Integer) return Integer; + pragma Export (C, vpi_control); + ------------------------------------------------------------------------------- -- * * * G H D L h o o k s * * * * * * * * * * * * * * * * * * * * * * * ------------------------------------------------------------------------------- procedure Register; +private + type struct_vpiHandle (mType : Integer) is record + case mType is + when vpiCallback => + Cb : aliased s_cb_data; + Cb_Prev, Cb_Next : vpiHandle; + Cb_Wire : Grt.Vcd.Verilog_Wire_Info; + Cb_Handle : Callbacks.Callback_Handle; + when others => + Ref : VhpiHandleT; + end case; + end record; end Grt.Vpi; - diff --git a/src/grt/grt-waves.adb b/src/grt/grt-waves.adb index 72b33d3e2..34124e2fc 100644 --- a/src/grt/grt-waves.adb +++ b/src/grt/grt-waves.adb @@ -1559,7 +1559,7 @@ package body Grt.Waves is Wave_Put_Byte (0); Wave_Put_Byte (0); Wave_Put_Byte (0); - Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + Wave_Put_I64 (Ghdl_I64 (Current_Time)); for I in Dump_Table.First .. Dump_Table.Last loop Write_Signal_Value (Dump_Table.Table (I)); @@ -1629,23 +1629,23 @@ package body Grt.Waves is begin if not In_Cyc then Wave_Section ("CYC" & NUL); - Wave_Put_I64 (Ghdl_I64 (Cycle_Time)); + Wave_Put_I64 (Ghdl_I64 (Current_Time)); In_Cyc := True; else - Diff := Cycle_Time - Wave_Time; + Diff := Current_Time - Wave_Time; Wave_Put_LSLEB128 (Ghdl_I64 (Diff)); end if; - Wave_Time := Cycle_Time; + Wave_Time := Current_Time; -- Dump signals. Last := 0; for I in Dump_Table.First .. Dump_Table.Last loop Sig := Dump_Table.Table (I); - if Sig.Flags.Cyc_Event then + if Sig.Flags.RO_Event then Wave_Put_ULEB128 (Ghdl_U32 (I - Last)); Last := I; Write_Signal_Value (Sig); - Sig.Flags.Cyc_Event := False; + Sig.Flags.RO_Event := False; end if; end loop; Wave_Put_Byte (0); -- cgit v1.2.3