summaryrefslogtreecommitdiff
path: root/src/grt
diff options
context:
space:
mode:
Diffstat (limited to 'src/grt')
-rw-r--r--src/grt/grt-avhpi.adb116
-rw-r--r--src/grt/grt-avhpi.ads12
-rw-r--r--src/grt/grt-callbacks.adb207
-rw-r--r--src/grt/grt-callbacks.ads107
-rw-r--r--src/grt/grt-cvpi.c31
-rw-r--r--src/grt/grt-disp_signals.adb3
-rw-r--r--src/grt/grt-errors.adb3
-rw-r--r--src/grt/grt-errors.ads13
-rw-r--r--src/grt/grt-fst.adb7
-rw-r--r--src/grt/grt-hooks.adb2
-rw-r--r--src/grt/grt-hooks.ads22
-rw-r--r--src/grt/grt-main.adb4
-rw-r--r--src/grt/grt-options.adb28
-rw-r--r--src/grt/grt-options.ads7
-rw-r--r--src/grt/grt-processes.adb227
-rw-r--r--src/grt/grt-processes.ads3
-rw-r--r--src/grt/grt-rtis_addr.adb6
-rw-r--r--src/grt/grt-signals.adb179
-rw-r--r--src/grt/grt-signals.ads51
-rw-r--r--src/grt/grt-std_logic_1164.ads2
-rw-r--r--src/grt/grt-types.ads3
-rw-r--r--src/grt/grt-vcd.adb35
-rw-r--r--src/grt/grt-vcd.ads4
-rw-r--r--src/grt/grt-vpi.adb799
-rw-r--r--src/grt/grt-vpi.ads116
-rw-r--r--src/grt/grt-waves.adb12
26 files changed, 1505 insertions, 494 deletions
diff --git a/src/grt/grt-avhpi.adb b/src/grt/grt-avhpi.adb
index 535cb0a..75bc946 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 b61b1ff..9609882 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 0000000..fba4048
--- /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 0000000..05d01b3
--- /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 51edd67..3e427c5 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 ebb2499..684a454 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 66dfbf1..62ee86e 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 833cded..bb7aab9 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 6292668..a87a4e1 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 44a9b7a..991a3a3 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 1243908..576ab48 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 743e4b3..4b2614a 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 a03b6be..806d774 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 44a85b6..604952e 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 748ab6d..feb3123 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 ecef800..00b057e 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 444f1f0..48ab477 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 fc97729..b86e234 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 8461e5e..36ef692 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 4d15695..b3b5d29 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 c0b3c3b..7198711 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 13da7f9..d29ae23 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 a3561f5..bc7917c 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 bc594e4..eedb846 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,47 +1265,18 @@ 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
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 86fb073..ddfc7cf 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 72b33d3..34124e2 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);
generated by cgit (git 2.34.1) at 2024-12-20 14:29:28 +0000